Theory Phi_BI

(*TODO: lift it to a chapter*)
section ‹A Bunched Implications Equipped with Satisfaction›

text ‹It also contains a simplified BI specialized for only necessary constructs required
  by ∗‹Multi-Term Form›.

➧ ∗‹Multi-Term Form› is the canonical form in the reasoning of φ-System, which demonstrates
  abstractions directly and clearly in a localized way. It is characterized by form,
\[ ‹∃a. (x⇩1 ⦂ T⇩1 ∗ x⇩2 ⦂ T⇩2 ∗ ⋯ x⇩n ⦂ T⇩n) ∧ P› \]
where ‹P› is a pure proposition only containing free variables occurring in ‹x⇩1,⋯,x⇩n,a›.
It relates the concrete resource to a set of abstract objects ‹{(x⇩1,⋯,x⇩n) |a. P}› if
  ∗‹variables ‹a› are not free in ‹T⇩1,⋯,T⇩n››.
All specifications in φ-System are in Multi-Term Form. It is so pervasive that we use a set-like
notation to denote them,
\[ ‹(x⇩1 ⦂ T⇩1 ∗ x⇩2 ⦂ T⇩2 ∗ ⋯ x⇩n ⦂ T⇩n 𝗌𝗎𝖻𝗃 a. P)› \]
Readers may read it as a set,
\[ ‹{ x⇩1 ⦂ T⇩1 ∗ x⇩2 ⦂ T⇩2 ∗ ⋯ x⇩n ⦂ T⇩n |a. P }› \]

➧ ∗‹Simple Multi-Term Form› is a MTF where there is no existential quantification and the attached
  ‹P› is trivial ‹True›, viz., it is characterized by
  \[ ‹x⇩1 ⦂ T⇩1 ∗ ⋯ ∗ x⇩n ⦂ T⇩n› \]
›

text ‹
Specifically, in this minimal specialized BI:

  ▪ It does not have a general additive conjunction (‹∧›) that connects any BI assertions,
    but only the one (‹A 𝗌𝗎𝖻𝗃 P›) connects a BI assertion ‹A› and a pure assertion ‹P›,
    because it is exactly what at most the MTF requires.

  ▪ Implication does not occur in assertions (of φ-SL), but it represents transformations of
    abstraction so has a significant role in reasoning (rules).
    We emphasize this transformation by assigning the implication with notation
    ‹A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ≜ A ⟶ B ∧ P›, where ‹P› is a pure assertion.
    The ‹P› helps to capture the information (in abstract domain) lost in the
    weakening of this implication.
    Currying implications like ‹A ⟶ B ⟶ C› are never used in φ-BI.

  ▪ Optionally we have universal quantification. It can be used to quantify free variables
    if for any reason free variables are inadmissible. The universal quantifier is typically
    not necessary in φ-BI and φ-SL, where we use free variables directly. However, in some
    situation, like when we consider transitions of resource states and we want a transition
    relation for each procedure, we need a single universally quantified assertion,
    instead of a family of assertions indexed by free variables.

  ▪ The use of a implication represents a transformation of abstraction.
    Therefore, implications are never curried or nested, always in form ‹X ⟶ Y ∧ P›
    where ‹X, Y› are MTF and ‹P› is a pure proposition.
    We denote them by notation ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›.

  ▪ It only has multiplicative conjunctions, specialized additive conjunction described above,
    existential quantification, and optionally universal quantification,
    which are all the MTF requires,
    plus implications that only occur in reasoning rules.
    Any other things, should be some specific φ-Types expressing their meaning
    specifically and particularly.
›

theory Phi_BI
  imports "Phi_Logic_Programming_Reasoner.PLPR" Phi_Preliminary
  abbrevs "<:>" = "⦂"
      and "<trans>" = "𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌"
      and "<transforms>" = "𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌"
      and "<with>"  = "𝗐𝗂𝗍𝗁"
      and "<subj>" = "𝗌𝗎𝖻𝗃"
      and "<when>" = "𝗐𝗁𝖾𝗇"
      and "<remains>" = "𝗋𝖾𝗆𝖺𝗂𝗇𝗌"
      and "<get>" = "𝗀𝖾𝗍"
      and "<map>" = "𝗆𝖺𝗉"
      and "<by>" = "𝖻𝗒"
      and "<from>" = "𝖿𝗋𝗈𝗆"
      and "<remaining>" = "𝗋𝖾𝗆𝖺𝗂𝗇𝗂𝗇𝗀"
      and "<demanding>" = "𝖽𝖾𝗆𝖺𝗇𝖽𝗂𝗇𝗀"
      and "<to>" = "𝗍𝗈"
      and "<over>" = "𝗈𝗏𝖾𝗋"
      and "<subst>" = "𝗌𝗎𝖻𝗌𝗍"
      and "<for>" = "𝖿𝗈𝗋"
      and "<TP>" = "𝒯𝒫"
begin

type_synonym 'a BI = ‹'a set›

subsection ‹Satisfaction›

definition Satisfaction :: ‹'a ⇒ 'a BI ⇒ bool› (infix "⊨" 50) where ‹(⊨) = (∈)›

subsubsection ‹Basic Rules›

lemma BI_eq_iff:
  ‹S = S' ⟷ (∀u. u ⊨ S ⟷ u ⊨ S')›
  unfolding Satisfaction_def set_eq_iff ..

subsubsection ‹Basic Rewrites›

lemma sep_conj_expn[simp, φexpns]:
  ‹uv ⊨ (S * T) ⟷ (∃u v. uv = u * v ∧ u ⊨ S ∧ v ⊨ T ∧ u ## v)›
  unfolding Satisfaction_def
  using set_mult_expn .

lemma Subjection_expn[iff, φexpns]:
  ‹p ⊨ (S 𝗌𝗎𝖻𝗃 P) ⟷ p ⊨ S ∧ P›
  unfolding Satisfaction_def using Subjection_expn_set .

lemma ExSet_expn[iff, φexpns]:
  ‹p ⊨ (ExSet S) ⟷ (∃x. p ⊨ S x)›
  unfolding Satisfaction_def using ExSet_expn_set .

lemma Bottom_expn[iff, φexpns]:
  ‹¬ (p ⊨ {})›
  unfolding Satisfaction_def by simp

lemma Zero_expn[iff, φexpns]:
  ‹¬ (p ⊨ 0)›
  unfolding Satisfaction_def by simp

lemma One_expn[iff, φexpns]:
  ‹v ⊨ 1 ⟷ v = 1›
  unfolding Satisfaction_def by simp

lemma Top_expn[iff, φexpns]:
  ‹v ⊨ top›
  unfolding Satisfaction_def by simp

subsubsection ‹Reasoning Configuration›

φreasoner_group extract_pure_sat = (%extract_pure+100, [%extract_pure+100, %extract_pure+130])
                                    for (‹𝗋EIF _ _›, ‹𝗋ESC _ _›)
                                     in extract_pure_all and > extract_pure
  ‹Rules extracting BI properties down to Satisfaction›

subsection ‹φ-Type›

type_synonym ('concrete,'abstract) φ = " 'abstract ⇒ 'concrete BI "

definition φType :: "'b ⇒ ('a,'b) φ ⇒ 'a BI" (infix "⦂" 20) where " x ⦂ T ≡ T x"

text ‹Convention of name:

In ‹x ⦂ T›, we refer to ‹x› as the ∗‹object› or the ∗‹φ-type term› and ‹T› as the ∗‹φ-type›.
For convenience, when the context is unambiguous, we also call the entire ‹x ⦂ T› as 'φ-type',
but as ∗‹φ-type assertion› to be precise.
›

subsubsection ‹Basic \& Auxiliary Rules›

lemma φType_eqI:
  ‹(∀x p. p ⊨ (x ⦂ a) ⟷ p ⊨ (x ⦂ b)) ⟹ a = b›
  unfolding φType_def Satisfaction_def by blast

lemma φType_protect_type_cong:
  ‹ x ≡ x'
⟹ x ⦂ T ≡ x' ⦂ T›
  by simp

setup ‹Context.theory_map (PLPR_Rule_Gen.Rule_Gen_SS.map (
  Simplifier.add_cong @{thm' φType_protect_type_cong}))›

ML_file ‹library/tools/simp_congruence.ML›

subsection ‹Inhabitance›

definition Satisfiable :: " 'a BI ⇒ bool "
  where "Satisfiable S = (∃p. p ⊨ S)"
  ― ‹‹Satisfiable S› should be always regarded as an atom in the view of ATPs.

      The fallback of extracting implied pure facts returns the original ‹Satisfiable T› unchanged,
      ‹P 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Satisfiable P› where ‹Satisfiable P› should be regarded as an atom.›

definition Inhabited
  where ‹Inhabited T ⟷ (∃x. Satisfiable (x ⦂ T))›


abbreviation Inhabitance_Implication :: ‹'a BI ⇒ bool ⇒ bool› (infix "𝗂𝗆𝗉𝗅𝗂𝖾𝗌" 10)
  where ‹S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P ≡ 𝗋EIF (Satisfiable S) P ›
  ― ‹P is weaker than S. We want to get a simpler P and as strong as possible. ›

abbreviation Sufficient_Inhabitance :: ‹bool ⇒ 'a BI ⇒ bool› (infix "𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌" 10)
  where ‹P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S ≡ 𝗋ESC P (Satisfiable S) ›
  ― ‹P is stronger than S. We want to get a simpler P and as weak as possible. ›

declare [[
  φreason_default_pattern ‹Satisfiable ?X ⟶ _› ⇒ ‹ERROR TEXT(‹bad form›)› (100)
                      and ‹_ ⟶ Satisfiable ?X› ⇒ ‹ERROR TEXT(‹bad form›)› (100)
                      and ‹Inhabited ?T›  ⇒ ‹Inhabited ?T›      (100),
  φpremise_attribute once? [φreason? %local] for ‹Inhabited _›  (%φattr)
]]

φreasoner_group extract_pure_phity = (10, [10,10]) for (‹x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P›, ‹P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T›)
  > extract_pure_fallback and < extract_pure
  ‹Entry points towards ‹Abstract_Domain› and ‹Abstract_Domain⇩L› ›

subsubsection ‹Basic Rules›

lemma Satisfiable_I:
  ‹x ⊨ S ⟹ Satisfiable S›
  unfolding Satisfiable_def ..

lemma Satisfiable_fallback:
  ‹ X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Satisfiable X ›
  unfolding 𝗋EIF_def by blast

lemma Suf_Satisfiable_fallback:
  ‹ Satisfiable X 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X ›
  unfolding 𝗋ESC_def by blast

φreasoner_ML Satisfiable_fallback default 2 (‹_ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _›) =
‹fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Satisfiable_fallback} RS sequent), Seq.empty)
)›

φreasoner_ML Suf_Satisfiable_fallback default 2 (‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 _›) =
‹fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Suf_Satisfiable_fallback} RS sequent), Seq.empty)
)›

lemma [φreason 1000]:
  ‹ P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ Satisfiable A›
  unfolding 𝗋ESC_def Premise_def
  by blast

lemma inhabited_type_EIF':
  ‹ 𝗋EIF (Inhabited T) (∃x. Satisfiable (x ⦂ T)) ›
  unfolding Inhabited_def 𝗋EIF_def
  by blast

bundle deriving_intabited_type = inhabited_type_EIF'[φreason default %extract_pure]



paragraph ‹Sum Type›

lemma [φreason 1020]:
  ‹ A a 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
⟹ case_sum A B (Inl a) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P›
  by simp

lemma [φreason 1020]:
  ‹ B b 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
⟹ case_sum A B (Inr b) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P›
  by simp

lemma [φreason 1000]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ A a 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P a)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ B b 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q b)
⟹ case_sum A B x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 case_sum P Q x ›
  by (cases x; simp)



subsection ‹Abstract Domain›

lemma typing_inhabited: "p ⊨ (x ⦂ T) ⟹ Satisfiable (x ⦂ T)"
  unfolding Satisfiable_def φType_def by blast

definition Abstract_Domain :: ‹('c,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Abstract_Domain T d ⟷ (∀x. x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 d x)›
  ― ‹Upper Bound›

definition Abstract_Domain⇩L :: ‹('c,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Abstract_Domain⇩L T d ⟷ (∀x. d x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T)›
  ― ‹Lower Bound›

declare [[
  φreason_default_pattern ‹Abstract_Domain ?T _› ⇒ ‹Abstract_Domain ?T _› (100)
                      and ‹Abstract_Domain⇩L ?T _› ⇒ ‹Abstract_Domain⇩L ?T _› (100),
  φpremise_attribute once? [φreason? %local] for ‹Abstract_Domain  _ _›  (%φattr) ,
  φpremise_attribute once? [φreason? %local] for ‹Abstract_Domain⇩L _ _›  (%φattr)
]]

φreasoner_group abstract_domain_all = (1000, [1, 2000]) for (‹Abstract_Domain T d›, ‹Abstract_Domain⇩L T d›)
    ‹All reasoning rules giving ‹Abstract_Domain› or ‹Abstract_Domain⇩L››
  and abstract_domain = (1000, [1000, 1000]) for (‹Abstract_Domain T d›, ‹Abstract_Domain⇩L T d›)
                                             in abstract_domain_all
    ‹Normal reasoning rules for ‹Abstract_Domain›, ‹Abstract_Domain⇩L››
  and abstract_domain_fallback = (1, [1,1]) for (‹Abstract_Domain T d›, ‹Abstract_Domain⇩L T d›) < abstract_domain
                                            in abstract_domain_all
    ‹Fallbacks reasoning rules for ‹Abstract_Domain›, ‹Abstract_Domain⇩L› ›
  and derived_abstract_domain = (60, [50,70]) for (‹Abstract_Domain T d›, ‹Abstract_Domain⇩L T d›)
                                              in abstract_domain_all and < abstract_domain
    ‹Automatically derived rules›

  and extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌 = (%extract_pure+40, [%extract_pure+40, %extract_pure+70])
                       for (‹𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) Q›, ‹𝗋ESC Q (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P)›,
                            ‹𝗋EIF (A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 P) Q›, ‹𝗋ESC Q (A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 P)›)
                       and > extract_pure and < extract_pure_sat ‹›


subsubsection ‹Extracting Pure Facts›

lemma Inhabitance_Implication_𝒜EIF [φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  ‹ 𝗋ESC A' (Satisfiable A)
⟹ 𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) (A' ⟶ P) ›
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Inhabitance_Implication_𝒜EIF_Sat:
  ‹ 𝗋EIF (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) ((∃v. v ⊨ A) ⟶ P) ›
  unfolding 𝗋EIF_def Satisfiable_def
  by blast

lemma Inhabitance_Implication_𝒜ESC[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  ‹ 𝗋EIF (Satisfiable A) A'
⟹ 𝗋ESC (A' ⟶ P) (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) ›
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Inhabitance_Implication_𝒜ESC_Sat:
  ‹ 𝗋ESC ((∃v. v ⊨ A) ⟶ P) (A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P) ›
  unfolding 𝗋ESC_def 𝗋EIF_def Satisfiable_def
  by blast

lemma Sufficient_Inhabitance_𝒜EIF[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  ‹ 𝗋EIF (Satisfiable A) A'
⟹ 𝗋EIF (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) (P ⟶ A') ›
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Sufficient_Inhabitance_𝒜EIF_Sat:
  ‹ 𝗋EIF (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) (P ⟶ (∃v. v ⊨ A)) ›
  unfolding 𝗋EIF_def 𝗋ESC_def Satisfiable_def
  by blast

lemma Sufficient_Inhabitance_𝒜ESC[φreason %extract_𝗂𝗆𝗉𝗅𝗂𝖾𝗌]:
  ‹ 𝗋ESC A' (Satisfiable A)
⟹ 𝗋ESC (P ⟶ A') (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) ›
  unfolding 𝗋EIF_def 𝗋ESC_def
  by blast

lemma Sufficient_Inhabitance_𝒜ESC_Sat:
  ‹ 𝗋ESC (P ⟶ (∃v. v ⊨ A)) (P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A) ›
  unfolding 𝗋ESC_def Satisfiable_def
  by blast

bundle extracting_Inhabitance_Implication_sat =
          Inhabitance_Implication_𝒜EIF_Sat [φreason %extract_pure_sat]
          Inhabitance_Implication_𝒜ESC_Sat [φreason %extract_pure_sat]
bundle extracting_Sufficient_Inhabitance_sat =
          Sufficient_Inhabitance_𝒜EIF_Sat [φreason %extract_pure_sat]
          Sufficient_Inhabitance_𝒜ESC_Sat [φreason %extract_pure_sat]
bundle extracting_Inhabitance_sat begin
  unbundle extracting_Inhabitance_Implication_sat extracting_Sufficient_Inhabitance_sat
end

lemma [φreason %extract_pure_all]:
  ‹ (⋀x. 𝗋EIF ((x ⦂ T) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x) (P x))
⟹ 𝗋EIF (Abstract_Domain T D) (All P) ›
  unfolding Abstract_Domain_def 𝗋EIF_def
  by blast

lemma [φreason %extract_pure_all]:
  ‹ (⋀x. 𝗋ESC (P x) ((x ⦂ T) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x))
⟹ 𝗋ESC (All P) (Abstract_Domain T D) ›
  unfolding Abstract_Domain_def 𝗋ESC_def
  by blast

lemma [φreason %extract_pure_all]:
  ‹ (⋀x. 𝗋EIF (D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 (x ⦂ T)) (P x))
⟹ 𝗋EIF (Abstract_Domain⇩L T D) (All P) ›
  unfolding Abstract_Domain⇩L_def 𝗋EIF_def
  by blast

lemma [φreason %extract_pure_all]:
  ‹ (⋀x. 𝗋ESC (P x) (D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 (x ⦂ T)))
⟹ 𝗋ESC (All P) (Abstract_Domain⇩L T D) ›
  unfolding Abstract_Domain⇩L_def 𝗋ESC_def
  by blast


subsubsection ‹Basic Rules›

lemma [φreason default %extract_pure_phity]:
  ‹ Abstract_Domain T D
⟹ x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 D x›
  unfolding Abstract_Domain_def Action_Tag_def
  by blast

lemma [φreason default %extract_pure_phity]:
  ‹ Abstract_Domain⇩L T D
⟹ D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T›
  unfolding Abstract_Domain⇩L_def Action_Tag_def
  by blast

lemma [φreason default %extract_pure_phity]:
  ‹ Abstract_Domain⇩L T D
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (∃x. D x)
⟹ Inhabited T ›
  unfolding Inhabited_def Abstract_Domain⇩L_def Premise_def 𝗋ESC_def
  by blast

subsubsection ‹Fallback›

lemma [φreason default %abstract_domain_fallback]:
  ‹ Abstract_Domain T (λx. Satisfiable (x ⦂ T)) ›
  unfolding Abstract_Domain_def 𝗋EIF_def
  by simp

lemma [φreason default %abstract_domain_fallback]:
  ‹ Abstract_Domain⇩L T (λx. Satisfiable (x ⦂ T)) ›
  unfolding Abstract_Domain⇩L_def 𝗋ESC_def
  by simp

subsubsection ‹Configuration›

declare [[
  φreason_default_pattern_ML ‹?x ⦂ ?T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _› ⇒ ‹
    fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*𝗋EIF*) $ (
                            _ (*Satisfiable*) $ (_ (*φType*) $ x $ _)) $ _)) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Implication Rule: in ‹x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 _› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end)› (1000),

  φreason_default_pattern_ML ‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 _ ⦂ _› ⇒ ‹
    fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*𝗋ESC*) $ _ $ (
                            _ (*Satisfiable*) $ (_ (*φType*) $ x $ _)))) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Sufficiency Rule: in ‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end)› (1000)
]]

setup ‹ PLPR_Template_Properties.add_property_kinds [
  \<^pattern_prop>‹Abstract_Domain _ _›, \<^pattern_prop>‹Abstract_Domain⇩L _ _›
]›

subsubsection ‹Template Instantiation›

lemma Satisfiable_rewr_template[φreason_template name T.inh_rewr [simp]]:
  ‹ Abstract_Domain T D
⟹ Abstract_Domain⇩L T D'
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 (∀x. D' x = D x) @tag 𝒜_template_reason None
⟹ Satisfiable (x ⦂ T) ≡ D x ›
  unfolding 𝗋EIF_def 𝗋ESC_def Action_Tag_def Abstract_Domain_def Abstract_Domain⇩L_def Premise_def
  by (clarsimp, smt (verit, best))


(*
(*depreciate!*)
subsubsection ‹The Variant of Inhabitance for Separation Carrier›

definition Satisfiable⇩M⇩C :: " 'a::sep_carrier BI ⇒ bool " where  "Satisfiable⇩M⇩C S = (∃p. p ⊨ S ∧ mul_carrier p)"

abbreviation Inhabitance_Implication⇩M⇩C :: ‹'a::sep_carrier BI ⇒ bool ⇒ bool› (infix "𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C" 10)
  where ‹S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C P ≡ Satisfiable⇩M⇩C S ⟶ P @tag 𝒜EIF›
  ― ‹P is weaker than S. We want to get a simpler P and as strong as possible. ›

abbreviation Sufficient_Inhabitance⇩M⇩C :: ‹bool ⇒ 'a::sep_carrier BI ⇒ bool› (infix "𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C" 10)
  where ‹P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C S ≡ P ⟶ Satisfiable⇩M⇩C S @tag 𝒜ESC›
  ― ‹P is stronger than S. We want to get a simpler P and as weak as possible. ›

lemma Satisfiable⇩M⇩C_fallback_True:
  ‹ X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C True ›
  unfolding Action_Tag_def by blast

lemma Suf⇩M⇩C_Satisfiable_fallback_True:
  ‹ False 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C X ›
  unfolding Action_Tag_def by blast

φreasoner_ML Satisfiable_fallback⇩M⇩C default 2 (‹_ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C _›) =
‹fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Satisfiable⇩M⇩C_fallback_True} RS sequent), Seq.empty)
)›

φreasoner_ML Suf_Satisfiable_fallback⇩M⇩C default 2 (‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C _›) =
‹fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  if Config.get ctxt Phi_Reasoners.is_generating_extraction_rule
  then SOME ((ctxt, Thm.permute_prems 0 ~1 sequent), Seq.empty)
  else SOME ((ctxt, @{thm Suf⇩M⇩C_Satisfiable_fallback_True} RS sequent), Seq.empty)
)›

lemma [φreason 1000]:
  ‹ P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C A
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ Satisfiable⇩M⇩C A›
  unfolding Action_Tag_def Premise_def
  by blast


subsubsection ‹The Separation Carrier Variant for φ-Type›

definition Abstract_Domain⇩M⇩C :: ‹('c::sep_carrier,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Abstract_Domain⇩M⇩C T d ⟷ (∀x. x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C d x)›
  ― ‹Upper Bound›

definition Abstract_Domain⇩M⇩C⇩L :: ‹('c::sep_carrier,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Abstract_Domain⇩M⇩C⇩L T d ⟷ (∀x. d x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C x ⦂ T)›
  ― ‹Lower Bound›

declare [[φreason_default_pattern ‹Abstract_Domain⇩M⇩C ?T _› ⇒ ‹Abstract_Domain⇩M⇩C ?T _› (100)
                              and ‹Abstract_Domain⇩M⇩C⇩L ?T _› ⇒ ‹Abstract_Domain⇩M⇩C⇩L ?T _› (100) ]]

lemma [φreason default 10]:
  ‹ Abstract_Domain⇩M⇩C T D
⟹ x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C D x›
  unfolding Abstract_Domain⇩M⇩C_def Action_Tag_def
  by blast

lemma [φreason default 10]:
  ‹ Abstract_Domain⇩M⇩C⇩L T D
⟹ D x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C x ⦂ T›
  unfolding Abstract_Domain⇩M⇩C⇩L_def Action_Tag_def
  by blast

lemma [φreason default 1]:
  ‹ Abstract_Domain⇩M⇩C T (λ_. True) ›
  unfolding Abstract_Domain⇩M⇩C_def Action_Tag_def
  by simp

lemma [φreason default 1]:
  ‹ Abstract_Domain⇩M⇩C⇩L T (λ_. False) ›
  unfolding Abstract_Domain⇩M⇩C⇩L_def Action_Tag_def
  by simp

declare [[
  φreason_default_pattern_ML ‹?x ⦂ ?T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C _› ⇒ ‹
    fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*Action_Tag*) $ ( _ (*imp*) $ (
                            _ (*Satisfiable⇩M⇩C*) $ (_ (*φType*) $ x $ _)) $ _) $ _)) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Implication Rule: in ‹x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌⇩M⇩C _› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end)› (1000),

  φreason_default_pattern_ML ‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C _ ⦂ _› ⇒ ‹
    fn ctxt => fn tm as (_ (*Trueprop*) $ (_ (*Action_Tag*) $ ( _ (*imp*) $ _ $ (
                            _ (*Satisfiable⇩M⇩C*) $ (_ (*φType*) $ x $ _))) $ _)) =>
      if is_Var x orelse not (Context_Position.is_visible_generic ctxt)
      then NONE
      else error (let open Pretty in string_of (chunks [
            para "Malformed Sufficiency Rule: in ‹_ 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌⇩M⇩C x ⦂ T› the x must be a schematic variable. But given",
            Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
          ]) end)› (1000)
]]
*)

(*
lemma Membership_E_Inhabitance:
  ‹ x ⊨ S
⟹ Satisfiable S ⟶ C
⟹ C›
  unfolding Satisfiable_def by blast
*)

subsection ‹Auxiliary Tag›

definition φTag :: ‹mode ⇒ ('c,'x) φ ⇒ ('c,'x) φ›
  where ‹φTag mode T ≡ T›

definition φTagA :: ‹mode ⇒ 'c BI ⇒ 'c BI›
  where ‹φTagA mode T ≡ T›


subsection ‹Transformation of Abstraction›

text ‹The only meaningful implication ‹⟶› under the interpretation of φ data refinement›

definition Transformation :: " 'a BI ⇒ 'a BI ⇒ bool ⇒ bool " ("(2_)/ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (2_)/ 𝗐𝗂𝗍𝗁 (2_)" [13,13,13] 12)
  where "(A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) ⟷ (∀v. v ⊨ A ⟶ v ⊨ B ∧ P)"
  ― ‹Implementation notes: It is safe to unfold Transformation but unsafe to unfold Satisfaction.
      Transformation is always based on Satisfaction but in future when we upgrade our logic onto
      impredicativeness, the definition of Satisfaction will be changed.
      Satisfaction is the bottom abstraction layer.›

abbreviation SimpleTransformation :: " 'a BI ⇒ 'a BI ⇒ bool " ("(2_)/ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (2_)" [13,13] 12)
  where ‹SimpleTransformation T U ≡ Transformation T U True›

text ‹
Transformation ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. f x y› and its dual ‹y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗌𝗎𝖻𝗃 x. g x y›
constitute a classical Galios connection ‹(f,g)›. However, our method does not apply the Galios
connection directly as our method is synthetic (we do not analysis the relation between
concrete sets and abstract sets once after defining a φ-type,
but do deductions by means of transformation rules).
Comparing to analytic methods (the classical methods for data refinement), synthetic methods based
on a higher abstraction simplify representations and give more chances for automation (by means of an inference system),
and in addition, can be combined in program logics more natively.
›

text ‹The name of transformation is good in sense of corresponding to categorical natural transformation.
  If we consider the state transition of a program as a category ‹𝒞›, two φ-types ‹T› and ‹U› form
  functors over ‹𝒞›, and the transformation between ‹T› and ‹U› is the natural transformation between
  the two functors. ›

text ‹TODO: move me
Our method simplifies program verification by lifting it onto an abstract domain.
However, it is hard to universally define what are abstract and what are not.
In a transformation ‹x ⦂ T ⟶ f(x) ⦂ U›, the abstract map ‹f› can have various expressions and
may fall back to concrete level such as ‹f(x) = @y(x ⦂ T ⟶ y ⦂ U)› (‹@› is Hilbert choice operator)
which is always a trivial solution of ‹f›.


The criterion about what expression of ‹f› is considered abstract can be given by user.
The abstract maps (‹f›) occurring in their annotations or given properties are assumed abstract.
In addition, if the abstract objects ‹x› are defined algebraically using Bounded Natural Functor,
the implied operators including mapper, relator, predicator, etc. are also considered abstract.
The range is unfixed and may extended if reasonable.

When we say we lift the verification onto an abstract domain, precisely we mean the proof obligation
extracted by our reasoning is a boolean assertion consisting of only the abstract operators as above
plus boolean connectives and other basic primitives like projections of product type.
It basically means the reasoning is made by composition of the rules giving abstraction, and the
extracted proof obligation is a composition of the abstract operators given in the rules.
›


subsubsection ‹Rules›

lemma φType_eqI_Tr:
  ‹ (⋀x. x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ U)
⟹ (⋀x. x ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T)
⟹ T = U›
  unfolding φType_def Transformation_def Satisfaction_def
  by auto

lemma φType_eqI_BI:
  ‹ (⋀x. (x ⦂ T) = (x ⦂ U))
⟹ T = U ›
  unfolding φType_def fun_eq_iff
  by blast

lemma transformation_refl[simp]:
  "A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A" unfolding Transformation_def by fast

lemma transformation_trans:
  "A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹ (P ⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 C 𝗐𝗂𝗍𝗁 Q)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 C 𝗐𝗂𝗍𝗁 P ∧ Q"
  unfolding Transformation_def Premise_def by auto

lemma mk_intro_transformation:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ›
  unfolding Transformation_def
  by simp

lemma mk_elim_transformation:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  unfolding Transformation_def
  by simp blast

lemma transformation_weaken:
  ‹ P ⟶ P'
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P'›
  unfolding Transformation_def by simp

lemma transformation_intro_inhab:
  ‹ (𝗉𝗋𝖾𝗆𝗂𝗌𝖾 Satisfiable A ⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ›
  unfolding Transformation_def Satisfiable_def Satisfaction_def
  by blast

lemma assertion_eq_intro:
  ‹ P 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Q
⟹ Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 P
⟹ P = Q›
  unfolding Transformation_def BI_eq_iff by blast

lemma BI_eq_ToA:
  ‹ P = Q ⟷ (P 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Q) ∧ (Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 P) ›
  unfolding BI_eq_iff Transformation_def
  by blast

lemma BI_sub_transformation:
  ‹ S ≤ S' ⟷ (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S') ›
  unfolding Transformation_def Satisfaction_def subset_iff
  by blast

lemma BI_sub_iff:
  ‹ S ≤ S' ⟷ (∀u. u ⊨ S ⟶ u ⊨ S') ›
  unfolding Satisfaction_def subset_iff ..

lemma transformation_protector:
  ‹A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ≡ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P› .

subsubsection ‹Forms of Reasoning›

consts 𝒯𝒫  :: action ― ‹Transformation Problem, x : T --> f(x) : U, or between assertions, can be abductive
                         but never bi-abductive.›
       𝒯𝒫' :: action ― ‹Bi-abductive Transformation Problem with Remainders and Demands, x : T * W --> f(x) : U * R›

text ‹There are two kinds of transformation rule

▪ cast-rule: ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U 𝗐𝗂𝗍𝗁 P(x)› binding on pattern ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ U 𝗐𝗂𝗍𝗁 _›,
  which specifies how to transform a given φ-type ‹x ⦂ T› into the target type ‹U› and what is the
  resulted abstract object with yielding any auxiliary pure facts ‹P(x)›.

▪ intro-rule: ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 g(y) ⦂ U' 𝗐𝗂𝗍𝗁 P ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P ∧ Q(y)› binding on
  pattern ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 _›, which specifies how to construct ‹y ⦂ U› by construction
  from ‹g(y) ⦂ U'›.
    
▪ elim-rule: ‹g(x) ⦂ T' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ∧ Q(x)› binding on
  pattern ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›, which specifies how to destruct ‹x ⦂ T› in sense of opening
  its encapsulated abstraction to then deduce whatever we want.

(*TODO: revise the text below!!!*)
Among the rules generated from ‹φtype_def›, only the cast-rules are registered and activated.
Case-rule is point to point (from a specific type to another specific) so it is safe.
The intro-rule and the elim-rule reduce the abstraction level.
They cause the reasoning reduces to a lower level of abstraction.
Users can always activate the rules at their discretion.

Intro-rule and elim-rule can always be applied manually. It doesn't burden the user even a little because
the rules are used only when opening and closing an abstraction, in the case that should only happens
when building an interface or an internal operation of a data structure, where users can
write the intro-rule and the elim-rule at the beginning and the end of the program without thinking a bit.
›

text ‹In reasoning, the ‹P› in any goal is always an OUT-argument.›


text ‹Upon above, we present in addition two extension forms providing partial transformations
  where a part of the source object may transform to only a part of the target object, leaving some
  remainder of the source and some unsolved target part for later reasoning.

▸ ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U›, the usual one-φtype-to-one-φtype transformation.
▸ ‹x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R› or alternatively
  ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(x) ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cr] R(x)›, the transformation with remainders
▸ ‹x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R›, with both remainders and unsolved target parts.

where ‹Cw, Cr› are boolean conditions deciding if the remainder and respectively the unsolved aims
are presented.
The forms constitute a lattice where the reasoning of the bottom reduce to the top.

Note ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R› is not admissible though it is syntactically valid.
As it is entailed by the more general ‹x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (f(x), r(x)) ⦂ U ∗[Cr] R›, and more
important, the pattern of ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 …› also covers that of ‹x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _› when ‹T›
is variable, meaning inefficiency in selecting rule during reasoning, we dismiss ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 …›
for the sake of reasoning performance and reducing the total number of reasoning rules.

In this way, designers of φ-types only require to provide two forms of rules,
‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U› and ‹x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R›
›

definition REMAINS :: ‹ 'a::sep_magma BI ⇒ bool ⇒ 'a BI ⇒ 'a BI › ("_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _" [14,10,14] 13)
  where ‹(X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) ≡ if C then X * R else X›
  ― ‹The ‹C› should be a variable sending to the later reasoning which decides if the transformation
      results in some remainders. Or, exceptionally, ‹C› can be constant ‹True› for unital algebras
      and the later reasoning sets the remainder to ‹1› if it does not really results in remainders.

      It means, every reasoning procedure should prepare two versions, the one for variable ‹C›
      and another for the ‹C› of constant ‹True›.

      A reasoning procedure can at any time if on a unital algebra, set a variable ‹C› to ‹True›
      and turns the reasoning into the unital mode.›

abbreviation ALWAYS_REMAINS :: ‹ 'a::sep_magma BI ⇒ 'a BI ⇒ 'a BI › ("_/ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _" [14,14] 13)
  where ‹(X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R) ≡ X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R›

definition φProd :: " ('concrete::sep_magma, 'abs_a) φ ⇒ ('concrete, 'abs_b) φ ⇒ ('concrete, 'abs_a × 'abs_b) φ" (infixr "∗" 70)
  where "A ∗ B = (λ(a,b). A a * B b)"

definition Cond_φProd :: ‹ ('v,'x) φ ⇒ bool ⇒ ('v,'y) φ ⇒ ('v::sep_magma,'x × 'y) φ › ("_ ∗[_]/ _" [71,20,70] 70)
    ― ‹φType embedding of conditional remainder›
  where ‹(T ∗[C] U) ≡ if C then T ∗ U else (λx. fst x ⦂ T)›

lemma φProd_expn[φexpns, simp]:
  "concrete ⊨ (x ⦂ A ∗ B) ⟷ (∃ca cb. concrete = ca * cb ∧ cb ⊨ (snd x ⦂ B) ∧ ca ⊨ (fst x ⦂ A) ∧ ca ## cb)"
  unfolding φProd_def φType_def by (cases x; simp) blast

lemma Cond_φProd_expn'[simp, φexpns]:
  ‹ p ⊨ (x ⦂ T ∗[C] U) = (if C then p ⊨ (x ⦂ T ∗ U) else p ⊨ (fst x ⦂ T)) ›
  unfolding Cond_φProd_def φType_def
  by clarsimp

lemma REMAINS_simp[simp, φsafe_simp]:
  ‹X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R ≡ X * R›
  ‹X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] R ≡ X›
  unfolding REMAINS_def
  by simp_all

text ‹In reasoning, the ‹P,R,W› in any goal are always OUT-arguments.›

ML ‹val phi_allow_source_object_to_be_not_variable =
          Config.declare_bool ("phi_allow_source_object_to_be_not_variable", ⌂) (K false)›

ML_file ‹library/syntax/transformation.ML›

declare [[
  (*a general checker warns if the abstract object of the source is not a variable*)
  φreason_default_pattern_ML ‹_ ⦂ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› ⇒ ‹fn ctxt =>
    fn tm as (Trueprop $ (Transformation $ (PhiTyp $ x $ _) $ _ $ _)) => (
      if not (is_Var (Term.head_of x)) andalso
         Context_Position.is_visible_generic ctxt andalso
         not (Config.get_generic ctxt phi_allow_source_object_to_be_not_variable)
      then warning (let open Pretty in string_of (chunks [
              para "The abstract object of the source of a transformation rule should be a variable.\n",
              Context.cases Syntax.pretty_term_global Syntax.pretty_term ctxt tm
            ]) end)
      else () ;
      NONE
  )› (1000),

  φreason_default_pattern
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _› ⇒ ‹ERROR(TEXT(‹Transformation rules must be tagged by either of the following categories, 𝒯𝒫, 𝒯𝒫'›))› (10)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫› ⇒
      ‹ERROR(TEXT(‹Malformed Rule› (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫)))› (10)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫'› ⇒
      ‹ERROR(TEXT(‹Malformed Rule› (?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫')))› (10)

  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫› ⇒
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _  @tag 𝒯𝒫›   (30)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (50)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (50)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (60)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (_ ⦂ ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?var_y ⦂ ?U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (60)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (60)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (_ ⦂ ?U) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
   ⇒ ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA ?mode (?var_y ⦂ ?U) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› (60)

  and ‹?x ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y ⦂ ?U ∗[?Cr] ?R 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫› ⇒
          ‹ERROR TEXT(‹Malformed Rule. Please use›
                      (x ⦂ ?T ∗[False] Top 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y ⦂ ?U ∗[?Cr] ?R 𝗐𝗂𝗍𝗁 ?P)
                      ‹instead of the given›
                      (?x ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y ⦂ ?U ∗[?Cr] ?R 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫))› (71)
  

  and ‹_ ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
   ⇒ ‹_ ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌  _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› (40)
  and ‹?var_X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
   ⇒ ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› (40)
  and ‹(?var_x, _) ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
   ⇒ ‹_ ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› (50)
  and ‹?var_x ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
   ⇒ ‹_ ⦂ ?T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?U ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› (50)
]]
(*
declare [[
  φreason_default_pattern_ML ‹?var_X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 _ @tag ?A›
                          ⇒ ‹fn ctxt => fn tm =>
    if Phi_Syntax.is_intro_transformation (@{print} tm)
    then let val i = maxidx_of_term tm + 1
             fun var N = Var((N,i),TVar((N,i),[]))
          in case tm
               of Trueprop $ (Tag $ (Trans $ X $ Y $ P) $ A) =>
                  SOME [Trueprop $ (Tag $ (Trans $ var "X" $ Y $ var "P") $ A)]
         end
    else NONE
  › (80),

  φreason_default_pattern_ML ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗐𝗂𝗍𝗁 _ @tag ?A› ⇒ ‹fn ctxt => fn tm =>
    if Phi_Syntax.is_elim_transformation tm
    then let val i = maxidx_of_term tm + 1
             fun var N = Var((N,i),TVar((N,i),[]))
          in case tm
               of Trueprop $ (Tag $ (Trans $ X $ Y $ P) $ A) =>
                  SOME [Trueprop $ (Tag $ (Trans $ X $ var "Y" $ var "P") $ A)]
         end
    else NONE
  › (80)
]]
*)

lemma REMAINS_expn[φexpns]:
  ‹ p ⊨ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) ⟷ (if C then p ⊨ A * R else p ⊨ A) ›
  unfolding REMAINS_def
  by simp

subsubsection ‹Allocation of Priorities›

φreasoner_group
  ToA_all         = (100, [0, 4999]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›
                    ‹Rules of transformation›
  ToA_bottom      = (0, [0, 15]) in ToA_all
                    ‹System transformation rules, of the lowest priority›
  ToA             = (100, [16, 4999]) in ToA_all > ToA_bottom
                    ‹User rules for transformation›
  ToA_bk          = (100, [16, 999]) in ToA
                    ‹Backtracking rules›
  ToA_cut         = (1000, [1000, 1399]) in ToA
                    ‹Deterministic transformation rules without backtracking, meaning the reasoning
                     on the specified cases is definite and no branching.›
  NToA_tgt        = (1430, [1400, 1499]) > ToA_cut in ToA
                    ‹›
  ToA_splitting     = (1550, [1500,1599]) > ToA_cut in ToA
                    ‹Transformation rules splitting the reasoning goal into more subgoals›
  ToA_splitting_target = (1600, [1600,1601]) > ToA_splitting in ToA
                    ‹split the separation sequent in the target part and reason the tranformation for
                     each separated item one by one.›
  ToA_assertion_cut = (1700, [1700,1899]) > ToA_splitting in ToA
                    ‹Deterministic transformation rules between unsplitted assertions.›
  ToA_normalizing = (2000, [1950, 2299]) > ToA_assertion_cut in ToA
                    ‹Rules normalizing the transformation problem. A normalization rule should neither
                     branch nor yield new subgoal, i.e., always from onetransformation to another
                     transformaiton. If it branches, see %ToA_branches; if yields new assertions,
                     see %ToA_assertion_cut›
  ToA_fixes_quant = (2500, [2500, 2590]) > NToA_tgt in ToA
                    ‹Transformation rules fixing quantified variables.›
  ToA_red         = (2600, [2600, 2649]) > ToA_fixes_quant in ToA
                    ‹Transformation rules reducing literal or trivial cases.›
  ToA_success     = (3000, [2960, 3499])
                    ‹Transformation rules that are shortcuts leading to success on special cases›
  ToA_systop      = (4900, [4900, 4999]) in ToA
                    ‹System rules of the highest priority›
  ToA_assigning_var = (4100, [4100, 4110]) in ToA and < ToA_systop
                    ‹Tranformation rules assigning variable targets or sources, of the highest priority
                     as occurrences of schematic variables are usually not considered in the subsequent
                     normal process of the reasoning, and may cause unexpected exception in them.›
  ToA_refl        = (4000, [3990, 4019]) in ToA and < ToA_assigning_var and > ToA_success
                    ‹Reflexive tranformation rules›
  ToA_splitting_source = (50, [50,50]) for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› < ToA_cut in ToA
                    ‹split the separation sequent in the source part and reason the tranformation for
                     each separated item one by one.›
  ToA_elim_intro  = (19, [19,19]) in ToA < default
                    ‹Elimination and introduction rules that unfold φ-types›
  ToA_weak        = (20, [20,24]) in ToA < default and > ToA_elim_intro
                    ‹Weak transformation rules giving some reasoning support temporarily and expecting to be orverride›
  ToA_derived     = (50, [25,79]) in ToA < default and > ToA_weak
                    ‹Automatically derived transformations. Many substructures are contained in this large range.›
  ToA_derived_red = (150, [130,170]) for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› > ToA_derived > default in ToA
                    ‹Automatically derived transformation reductions.›
  ToA_weak_red    = (120, [120,129]) for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› < ToA_derived_red in ToA
                    ‹Weak reduction rules giving some reasoning support temporarily and expecting to be orverride›
  ToA_user        = (100, [80,119]) in ToA and < ToA_weak_red and > ToA_derived
                    ‹default group for user rules›

declare [[
  φdefault_reasoner_group ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› : %ToA_user (10)
                      and ‹?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› : %ToA_elim_intro (100)
                      and ‹_ ⦂ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› : %ToA_elim_intro (100)
]]

paragraph ‹Bottom Groups›

φreasoner_group
  ToA_falling_latice = (1, [0,4]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom
                    ‹Fallbacks of transformation rules›
  ToA_unified_refl = (5, [5,6]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom and > ToA_falling_latice
                     ‹Reflexive tranformation rules with unification, of a low priority because
                      unification is aggresive.›
  ToA_derv_unify_refl = (7, [7,8]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom and > ToA_unified_refl
                     ‹derived ToA_unified_refl that override the default behaviors.›
  ToA_varify_target_object = (9, [9,9]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom and > ToA_derv_unify_refl
                    ‹Varifies the fixed target object, using Object_Equiv›
  ToA_inst_qunat  = (10, [10,10]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom and > ToA_varify_target_object
                    ‹Transformation rules instantiating quantified variables. It is unsafe unless
                     all fixable variables are fixed. If any variable is fixed later than the instantiation,
                     the instantiated schematic variable cannot caputure the later fixed variable.›
  ToA_branches    = (12, [11,15]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA_bottom and > ToA_inst_qunat
                    ‹Branching transformation rules.›


paragraph ‹Fallback›

text ‹There are two trivial solutions for such problem.

  On commutative algebra, a transformation can do nothing but simply return the source to the remainder
  and demand subsequent transformation to the target. Such transformation is of the lowest priority
  serving as a fallback of the ordinary reasoning.

  ‹ x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, fst x) ⦂ U ∗[True] T ›

  Another trivial solution is on unital algebras, where a transformation can assign the target object
  to the identity element of the type so the source term directly go to the remainder.

  ‹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (one, fst x) ⦂ U ∗[True] T › where ‹one ⦂ U ≡ emp›

  This is the fallback rule for unital algebras that are non-commutative, and in this case when
  all transformations from T to U fail, assigning ‹U› to identity element is the only available search
  branch so the fallback is safe. For commutative algebra, the previous fallback is applied.
  When ‹U› is kept swapping and all source terms are passed, the still remaining ‹U› is assigned
  with the identity element, so the case of ‹one ⦂ U ≡ emp› is still covered.



(*Implementation note:

  By default, such rule is not activated as it really does nothing, and clients have a way
  to know if the reasoning fails. However, if such fallback is expected, one can use reasoning goal
  ‹ Try Cs (x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R) ›
  in which boolean condition ‹Cs› returns whether the reasoning really ever made some changes.*)
 ›


text ‹Rules are given in §‹Reasoning/Basic Transformation Rules/Fallback››


subsubsection ‹Extracting Pure Facts Implies Inside›

lemma [φreason %extract_pure]:
  ‹ 𝗋EIF A P
⟹ 𝗋EIF (A @tag 𝒯𝒫) P ›
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  ‹ 𝗋EIF A P
⟹ 𝗋EIF (A @tag 𝒯𝒫') P ›
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  ‹ 𝗋ESC P A
⟹ 𝗋ESC P (A @tag 𝒯𝒫) ›
  unfolding Action_Tag_def .

lemma [φreason %extract_pure]:
  ‹ 𝗋ESC P A
⟹ 𝗋ESC P (A @tag 𝒯𝒫') ›
  unfolding Action_Tag_def .

text ‹This is used in φ-derivers, particularly in induction when›

lemma [φreason %extract_pure]:
  ‹ P⇩A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
⟹ B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P⇩B
⟹ 𝗋EIF (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) (P⇩A ⟶ P⇩B ∧ P) ›
  unfolding Action_Tag_def 𝗋EIF_def 𝗋ESC_def Satisfiable_def Transformation_def
  by clarsimp

ML ‹
fun extracting_elim_or_intro_ToA is_intro ctxt sequent =
  let val target = case HOLogic.dest_Trueprop (Thm.major_prem_of sequent)
                     of Const(\<^const_name>‹𝗋EIF›, _) $ target $ _ => target
                      | _ => raise THM ("extracting_elim_or_intro_ToA", 1, [sequent])
      fun get_concl (Const(\<^const_name>‹HOL.implies›, _) $ _ $ X) = get_concl X
        | get_concl X = X
      val concl = get_concl target
      fun get_V (A, B) = if is_intro then A else B
      val (A, B, Var p) = Phi_Syntax.dest_transformation (fst (HOLogic.dest_imp target))
      val Var v = get_V (A, B)

      fun parse_P (Var p) = p 
        | parse_P (Const(\<^const_name>‹HOL.conj›, _) $ Var p $ _) = p

   in case try Phi_Syntax.dest_transformation concl
   of SOME (A', B', P') => if get_V (A', B') = Var v andalso p = parse_P P'
      then SOME ((ctxt, @{lemma' ‹ 𝗋EIF S C
                              ⟹ 𝗋EIF ((A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A) ⟶ S) C ›
                             by simp}
                          RS sequent), Seq.empty)
      else NONE
  end
›

φreasoner_ML Transformation⇩I_𝒜EIF' %extract_pure+10 (‹𝗋EIF ((?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 ?var_P) ⟶ _) _ ›) = ‹
  fn (_, (ctxt, sequent)) => Seq.make (fn () => extracting_elim_or_intro_ToA true ctxt sequent)
›

φreasoner_ML Transformation⇩E_𝒜EIF' %extract_pure+10 (‹𝗋EIF ((_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 ?var_P) ⟶ _) _ ›) = ‹
  fn (_, (ctxt, sequent)) => Seq.make (fn () => extracting_elim_or_intro_ToA false ctxt sequent)
›


(*TODO*)
lemma ToA_EIF_sat:
  ‹ (⋀v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vA v : v ⊨ A)
⟹ (⋀v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vB v : v ⊨ B)
⟹ 𝗋EIF (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) (∀v. vA v ⟶ vB v ∧ P) ›
  unfolding 𝗋EIF_def Satisfiable_def Transformation_def Simplify_def
  by clarsimp

lemma ToA_ESC_sat:
  ‹ (⋀v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vA v : v ⊨ A)
⟹ (⋀v. 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 vB v : v ⊨ B)
⟹ 𝗋ESC (∀v. vA v ⟶ vB v ∧ P) (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) ›
  unfolding 𝗋ESC_def Satisfiable_def Transformation_def Simplify_def
  by clarsimp

bundle ToA_extract_pure_sat = ToA_EIF_sat[φreason %extract_pure_sat]
                              ToA_ESC_sat[φreason %extract_pure_sat]


subsubsection ‹Reasoning Configure›

ML_file ‹library/tools/helper_reasoners.ML›

paragraph ‹Auxiliary Tools›

definition May_Assign :: ‹'a ⇒ 'a ⇒ bool›
  where ‹May_Assign _ _ ≡ True›

φreasoner_group may_assign__all = (100, [1,2000]) for ‹May_Assign var val› ‹›
  and may_assign_success = (2000, [2000,2000]) in may_assign__all ‹›
  and may_assign_red = (1500, [1500, 1530]) in may_assign__all ‹›
  and may_assign_fallback = (1, [1,1]) in may_assign__all ‹›

lemma [φreason %may_assign_success for ‹May_Assign _ _›]:
  ‹ May_Assign z z ›
  unfolding May_Assign_def ..

lemma [φreason %may_assign_fallback]:
  ‹May_Assign x y ›
  unfolding May_Assign_def ..

lemma [φreason %may_assign_red]:
  ‹ May_Assign y z
⟹ May_Assign (snd (x,y)) z ›
  unfolding May_Assign_def ..



paragraph ‹Inhabitance Reasoning - Part II›

(*TODO: move me!!*)

lemma [φreason 1000]:
  ‹ Generate_Implication_Reasoning (Satisfiable X ⟶ Y) (Satisfiable X) Y ›
  unfolding Generate_Implication_Reasoning_def
  ..

lemma [φreason 1100]:
  ‹ Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
⟹ Generate_Implication_Reasoning (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y) (Satisfiable X) P ›
  unfolding Generate_Implication_Reasoning_def Transformation_def Satisfiable_def 𝗋EIF_def
  by blast

lemma [φreason 1000]:
  ‹ Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
⟹ Generate_Implication_Reasoning (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P) (Satisfiable X) (Q ∧ P) ›
  unfolding Generate_Implication_Reasoning_def Transformation_def Satisfiable_def 𝗋EIF_def
  by blast


subsection ‹Top›

notation top ("⊤")

subsubsection ‹Rewrites›

lemma Top_Satisfiable[simp]:
  ‹Satisfiable ⊤ ⟷ True›
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

φreasoner_group ToA_top = (%ToA_success, [%ToA_success-1, %ToA_success+1]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗐𝗂𝗍𝗁 _›
                          ‹Transformation rules handling ⊤›

text ‹The target part is assumed having no schematic variable, so it is safe to do such shortcuts
      comparing with the bottom-in-source.›

(*TODO!*)

declare [[φtrace_reasoning = 1]]

lemma [φreason %ToA_top]:
  ‹Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤›
  unfolding Transformation_def by blast

lemma [φreason %ToA_top]:
  ‹Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] ⊤›
  unfolding Transformation_def
  by simp

lemma [φreason %ToA_top]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * B
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] ⊤›
  by simp

lemma [φreason %ToA_top-1 for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ @tag 𝒯𝒫›]:
      ― ‹the case when the remainder is forced›
  ‹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * R @tag 𝒯𝒫
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R @tag 𝒯𝒫›
  by simp

lemma [φreason %ToA_top-1 for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ @tag 𝒯𝒫›]:
      ― ‹the case when the remainder is forced. Non-semigroup algebra is covered by what??? TODO!›
  ‹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * C * R @tag 𝒯𝒫
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * C 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R @tag 𝒯𝒫›
  for A :: ‹'a :: sep_semigroup BI›
  by (simp add: mult.assoc)

(*The following procedure only supports commutative semigroup*)
 
lemma [φreason %ToA_top+1 if ‹fn (ctxt,sequent) =>
          case Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
            of (_, (_ (*times*) $ _ $ R), _)
               => let fun chk (Const(\<^const_name>‹times›, _) $ X $ Const(\<^const_name>‹top›, _)) = chk X
                        | chk (Const(\<^const_name>‹top›, _)) = false
                        | chk _ = true
                   in chk R
                  end›]:
  ‹ Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R * ⊤ 𝗐𝗂𝗍𝗁 P
⟹ Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * R 𝗐𝗂𝗍𝗁 P›
  for Any :: ‹'a::sep_ab_semigroup BI›
  by (simp add: mult.commute)

(*when we reach here, it means R all consists of ⊤, so that we can eliminate them one-by-one,
  until the last one which can be done by ‹Any 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤› directly.
  Again we assume and only consider commutative semigroup*)

lemma [φreason %ToA_top]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * R 𝗐𝗂𝗍𝗁 P›
  for A :: ‹'a::sep_ab_semigroup BI›
  unfolding Transformation_def
  by (clarsimp, insert sep_disj_commuteI sep_mult_commute, blast)

lemma [φreason %ToA_top-1]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * R 𝗐𝗂𝗍𝗁 P›
  for A :: ‹'a::sep_algebra BI›
  unfolding Transformation_def
  by clarsimp (metis mult_1_class.mult_1_left sep_magma_1_right)

lemma [φreason %fail]:
  ‹ FAIL TEXT(‹Sorry, currently we do not support solving ‹⊤ * R› problems on non-monoidal and non-commutative group.›)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ * R 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def FAIL_def
  by blast



subsection ‹Bottom›

text ‹Despite of semantically ‹0 = ⊥› where syntactically ‹⊥ ≡ {}›, but there is not syntactically
  ‹0 ≡ {}›. We prefer to use ‹0› instead of the more usual ‹⊥› for the sake of forming
  a semiring together with ‹1 ≡ emp›, ‹*›, ‹+ ≡ ∨⇩B⇩I›, to leverage the existing automation of semiring.›

abbreviation Bottom ("⊥⇩B⇩I") where ‹Bottom ≡ (0::'a::sep_magma BI)›
abbreviation Bottom_abs ("⊥⇩λ") where ‹Bottom_abs ≡ (0 :: 'b ⇒ 'a::sep_magma BI)›

lemma bot_eq_BI_bot [φprogramming_base_simps, φprogramming_simps]:
  ‹bot = ⊥⇩B⇩I›
  unfolding zero_set_def ..

lemma zero_implies_any[simp]:
  ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 Any›
  unfolding Transformation_def zero_set_def Satisfaction_def by simp

subsubsection ‹Rewrites›

lemma Bot_Satisfiable[simp]:
  ‹ Satisfiable 0 ⟷ False ›
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

φreasoner_group ToA_bot = (%ToA_cut+5, [%ToA_cut, %ToA_cut+10]) for ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›
   ‹Transformation rules when the source assertion is 0.
    The rule is not of a highest priority because the target may contain schematic variables,
    and the usual reasoning procedure is still required to unfold the target connective-by-connective
    to ensure every variables inside is instantiated.›

lemma [φreason %ToA_cut for ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 False @tag 𝒯𝒫›
  unfolding Action_Tag_def
  by simp


lemma [φreason %ToA_bot for ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  ‹0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Any] 0 𝗐𝗂𝗍𝗁 False @tag 𝒯𝒫›
  using zero_implies_any Transformation_def Action_Tag_def
  by simp


paragraph ‹Reductions›

lemma [φreason %ToA_red for ‹0 * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹?var * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  ‹ 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X
⟹ 0 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X›
  by simp

lemma [φreason %ToA_red for ‹_ * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ * ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  ‹ 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X
⟹ R * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X›
  by simp

lemma [φreason %ToA_red for ‹_ + 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ + ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ Y + 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red for ‹0 + _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹?var + _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ 0 + Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + 0 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + 0 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var + _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫@tag 𝒯𝒫› ]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + X 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + 0 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ + ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + 0 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                            ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var + _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 + X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ 0 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ R * 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ R * 0 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ 0 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ 0 x * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp


subsection ‹Unit›

subsubsection ‹Properties›

lemma [φreason %extract_pure]:
  ‹1 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 True›
  unfolding 𝗋EIF_def
  by blast

lemma [φreason %extract_pure]:
  ‹ True 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 1 ›
  unfolding 𝗋ESC_def Satisfiable_def
  by simp

lemma Emp_Satisfiable[simp]:
  ‹ Satisfiable 1 ⟷ True ›
  unfolding Satisfiable_def
  by clarsimp

subsubsection ‹Transformation Rules›

lemma [φreason %ToA_success]:
  ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] X›
  for X :: ‹'a::sep_magma_1 BI›
  unfolding REMAINS_def Action_Tag_def by simp

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 * X 𝗐𝗂𝗍𝗁 P "
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left .

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 * X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left .

lemma [φreason %ToA_red]:
  " R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ 1 * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P "
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left .


subsection ‹Additive Disjunction›

text ‹Is the \<^term>‹(+) :: 'a BI ⇒ 'a BI ⇒ 'a BI› directly›

subsubsection ‹Basic Rules›

lemma Disjunction_expn[iff, φexpns]:
  ‹p ⊨ (A + B) ⟷ p ⊨ A ∨ p ⊨ B›
  unfolding Satisfaction_def by simp

lemma Add_Disj_Satisfiable[simp]:
  ‹ Satisfiable (A + B) ⟷ Satisfiable A ∨ Satisfiable B ›
  unfolding Satisfiable_def
  by clarsimp blast

lemma [φreason %cutting]:
  ‹ X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A
⟹ Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 B
⟹ X + Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A ∨ B›
  unfolding 𝗋EIF_def Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  ‹ A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X
⟹ B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 Y
⟹ A ∨ B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X + Y›
  unfolding 𝗋ESC_def Satisfiable_def
  by simp blast

text ‹The above two rules are reversible.›

lemma set_plus_inhabited[elim!]:
  ‹Satisfiable (S + T) ⟹ (Satisfiable S ⟹ C) ⟹ (Satisfiable T ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by (simp, blast)

lemma implies_union:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P›
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def
  by simp_all

declare add_mono[φreason 1000]


subsubsection ‹Transformation Rules›

paragraph ‹In Source›

lemma [φreason %ToA_splitting]:
  ‹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P2
⟹ A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1 ∨ P2›
  by (simp add: Transformation_def)

lemma [φreason %ToA_splitting]:
  ‹ B * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1
⟹ A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P2
⟹ (A + B) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P1 ∨ P2›
  by (simp add: Transformation_def distrib_left) blast

lemma [φreason %ToA_splitting+10]:
  ‹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RB 𝗐𝗂𝗍𝗁 P1
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RA 𝗐𝗂𝗍𝗁 P2
⟹ A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RA + RB 𝗐𝗂𝗍𝗁 P1 ∨ P2›
  by (cases C; simp add: Transformation_def; meson)

lemma [φreason %ToA_splitting+10]:
  ‹ B * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RB 𝗐𝗂𝗍𝗁 P1
⟹ A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RA 𝗐𝗂𝗍𝗁 P2
⟹ (A + B) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] RA + RB 𝗐𝗂𝗍𝗁 P1 ∨ P2›
  by (cases C; simp add: Transformation_def; blast)


paragraph ‹In Target›

lemma ToA_disj_target_A:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗐𝗂𝗍𝗁 P›
  unfolding plus_set_def
  by (metis implies_union(1) plus_set_def)

lemma ToA_disj_target_B:
  ‹  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗐𝗂𝗍𝗁 P›
  by (simp add: Transformation_def)
 
declare [[φreason ! %ToA_branches ToA_disj_target_A ToA_disj_target_B for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A + ?B 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫›]]

hide_fact ToA_disj_target_A ToA_disj_target_B

lemma ToA_disj_target_A':
  ‹  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹  X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def REMAINS_def Transformation_def
  by (cases C; simp add: distrib_left; blast)

lemma ToA_disj_target_B':
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A + B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def REMAINS_def Transformation_def
  by (cases C; simp add: distrib_left; blast)

declare [[φreason ! %ToA_branches ToA_disj_target_A' ToA_disj_target_B'
            for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A + ?B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]]

hide_fact ToA_disj_target_A' ToA_disj_target_B'



subsection ‹Existential Quantification›

lemma ExSet_inhabited_E[elim!]:
  ‹Satisfiable (ExSet S) ⟹ (⋀x. Satisfiable (S x) ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  ‹ (⋀x. S x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C x)
⟹ ExSet S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Ex C ›
  unfolding Satisfiable_def 𝗋EIF_def
  by (simp; blast)

lemma [φreason %cutting]:
  ‹ (⋀x. C x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S x)
⟹ Ex C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 ExSet S ›
  unfolding Satisfiable_def 𝗋ESC_def
  by (simp; blast)

lemma ExSet_Satisfiable[simp]:
  ‹ Satisfiable (∃*x. S x) ⟷ (∃x. Satisfiable (S x)) ›
  unfolding Satisfiable_def
  by clarsimp blast


subsubsection ‹Syntax›

syntax
  "_SetcomprNu" :: "'a ⇒ pttrns ⇒ bool ⇒ 'a BI"  ("_ 𝗌𝗎𝖻𝗃/ _./ _" [14,0,15] 14)

parse_translation ‹[
  (\<^syntax_const>‹_SetcomprNu›, fn ctxt => fn [X,idts,P] =>
  let fun subst l Bs (Free v) =
            let val i = find_index (fn v' => v = v') Bs
             in if i = ~1 then Free v else Bound (i+l)
            end
        | subst l Bs (A $ B) = subst l Bs A $ subst l Bs B
        | subst l Bs (Abs(N,T,X)) = Abs(N,T, subst (l+1) Bs X)
        | subst l Bs X = X
      fun trans_one (Bs,C) (Const(\<^syntax_const>‹_unit›, _))
            = Abs ("", \<^Type>‹unit›, C [])
        | trans_one (Bs,C) (Const(\<^const_syntax>‹Pair›, _)
                                $ (Const (\<^syntax_const>‹_constrain›, _) $ Free (A, T) $ Ac)
                                $ B)
            = Const(\<^const_syntax>‹case_prod›, dummyT) $ (
                Const(\<^syntax_const>‹_constrainAbs›, dummyT)
                  $ Abs (A, T, trans_one ((A,T)::Bs, C) B)
                  $ Ac
              )
        | trans_one (Bs,C) (Const(\<^const_syntax>‹Pair›, _)
                                $ (Const (\<^syntax_const>‹_constrain›, _)
                                      $ (Const (\<^syntax_const>‹_constrain›, _) $ Free (A, T) $ T') $ Ac)
                                $ B)
            = Const(\<^const_syntax>‹case_prod›, dummyT) $ (
                Const(\<^syntax_const>‹_constrainAbs›, dummyT)
                  $ (Const(\<^syntax_const>‹_constrainAbs›, dummyT)
                      $ Abs (A, T, trans_one ((A,T)::Bs, C) B)
                      $ T')
                  $ Ac
              )
        | trans_one (Bs,C) (Const(\<^const_syntax>‹Pair›, _)
                                $ Const (\<^syntax_const>‹_unit›, _)
                                $ B)
            = Const(\<^const_syntax>‹case_prod›, dummyT) $ (
                Const(\<^syntax_const>‹_constrainAbs›, dummyT)
                  $ Abs ("", dummyT, trans_one (Bs, C) B)
                  $ Const(\<^type_syntax>‹unit›, dummyT)
              )
        | trans_one (Bs,C) (Const (\<^syntax_const>‹_constrain›, _) $ Free (A, T) $ Ac)
            = Const(\<^syntax_const>‹_constrainAbs›, dummyT)
                  $ Abs (A, T, C ((A,T)::Bs))
                  $ Ac
      fun trans (Const (\<^syntax_const>‹_pttrns›, _) $ A $ B) Bs
            = Const (\<^const_syntax>‹ExSet›, dummyT) $ trans_one (Bs,trans B) A
        | trans B Bs
            = Const (\<^const_syntax>‹ExSet›, dummyT) $ trans_one (Bs, (fn Bs =>
                case P of(* Const (\<^syntax_const>‹_constrain›, _) $ Free ("True",_) $ _
                            => subst 0 Bs X
                        |*) Const (\<^const_syntax>‹top›, _)
                            => subst 0 Bs X
                        | _ => Const (\<^const_syntax>‹Subjection›, dummyT) $ subst 0 Bs X $ subst 0 Bs P
              )) B
   in trans idts [] end)
]›

print_translation ‹[
  (\<^const_syntax>‹ExSet›, fn ctxt => fn [X] =>
    let fun subst l Bs (Bound i)
              = if l <= i andalso i-l <= length Bs then List.nth(Bs, i-l) else Bound i
          | subst l Bs (Abs (N,T,X)) = Abs (N,T, subst (l+1) Bs X)
          | subst l Bs (A $ B) = subst l Bs A $ subst l Bs B
          | subst l Bs X = X
        fun trans (Vs,Bs) (Const(\<^const_syntax>‹case_prod›, _) $ Abs (A,T,X))
              = if T = \<^Type>‹unit› andalso A = ""
                then trans (Const(\<^syntax_const>‹_unit›, dummyT) :: Vs, Bs) X
                else let val bound = Const(\<^syntax_const>‹_bound›, dummyT) $ Free(A,T)
                      in trans (bound::Vs, bound::Bs) X
                     end
          | trans (Vs,Bs) (Abs(A,T, Const(\<^const_syntax>‹ExSet›, _) $ X))
              = let val bound = Const(\<^syntax_const>‹_bound›, dummyT) $ Free(A,T)
                    val var = fold (fn v => fn v' => Const(\<^const_syntax>‹Pair›,dummyT) $ v $ v')
                                    Vs bound
                    val (X',idts',P') = trans ([], bound :: Bs) X
                 in (X', Const(\<^syntax_const>‹_pttrns›, dummyT) $ var $ idts', P')
                end
          | trans (Vs,Bs0) (Abs(A,T,B))
              = let val bound = Const(\<^syntax_const>‹_bound›, dummyT) $ Free(A,T)
                    val v' = if T = \<^Type>‹unit› andalso A = ""
                             then Const(\<^syntax_const>‹_unit›, dummyT)
                             else bound
                    val var = fold (fn v => fn v' => Const(\<^const_syntax>‹Pair›,dummyT) $ v $ v')
                                    Vs v'
                    val Bs = bound :: Bs0
                    val (X,P) = case B of Const(\<^const_syntax>‹Subjection›, _) $ X $ P => (X,P)
                                        | _ => (B, Const(\<^const_syntax>‹top›, dummyT))
                 in (subst 0 Bs X, var, subst 0 Bs P)
                end
        val (X',idts',P') = trans ([],[]) X
     in Const(\<^syntax_const>‹_SetcomprNu›, dummyT) $ X' $ idts' $ P' end)
]›


subsubsection ‹Semantic Explanation›

text ‹Semantically, an existential quantification in BI actually represents union of resources
  matching the existentially quantified assertion, as shown by the following lemma.›

lemma " Union { S x |x. P x } = (S x 𝗌𝗎𝖻𝗃 x. P x) "
  by (simp add: set_eq_iff ExSet_def Subjection_def) blast

subsubsection ‹Basic Rules›

lemma BI_Ex_comm:
  ‹(∃* x y. A x y) = (∃* y x. A x y)›
  unfolding BI_eq_iff
  by (simp, blast)


subsubsection ‹Simplifications›

lemma ExSet_pair: "ExSet T = (∃*a b. T (a,b))"
  unfolding BI_eq_iff by clarsimp

lemma ExSet_simps[simp, φprogramming_base_simps, φsafe_simp]:
  ‹ExSet 0 = 0›
  ‹ExSet (λ_. T) = T›
  ‹((∃*c. X c) 𝗌𝗎𝖻𝗃 PP) = (∃*c. X c 𝗌𝗎𝖻𝗃 PP)›
  ‹(F' y 𝗌𝗎𝖻𝗃 y. embedded_func f' P' x' y) = (F' (f' x') 𝗌𝗎𝖻𝗃 P' x')›
(*  ‹(∃* x. x = t ∧ P x) = P t›
"⋀P. (∃x. x = t ∧ P x) = P t"
    "⋀P. (∃x. t = x ∧ P x) = P t"*)
  unfolding BI_eq_iff embedded_func_def
  by simp_all

lemma ExSet_defined[φprogramming_base_simps, simp, φsafe_simp]:
  ― ‹only safe for source side but unsafe for target side, because it could instantiate variables
      of types parameters which could be instantiated arbitrarily?... I am not pretty sure... It is subtle here›
  ‹(∃* x. F x 𝗌𝗎𝖻𝗃 x = y) = (F y)›
  ‹(∃* x. F x 𝗌𝗎𝖻𝗃 y = x) = (F y)›
  ‹(∃* x. F x 𝗌𝗎𝖻𝗃 x = y ∧ P x) = (F y 𝗌𝗎𝖻𝗃 P y)›
  ‹(∃* x. F x 𝗌𝗎𝖻𝗃 y = x ∧ P x) = (F y 𝗌𝗎𝖻𝗃 P y)›
  unfolding BI_eq_iff
  by simp_all

lemma Ex_transformation_expn:
  ‹((∃*x. A x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) ⟷ (∀x. A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)›
  unfolding Transformation_def ExSet_expn
  by blast

lemma ExSet_split_prod[φprogramming_base_simps, φsafe_simp]:
  ‹ (∃*x. (case x of (a,b) ⇒ f a b)) = (∃*a b. f a b) ›
  unfolding BI_eq_iff
  by clarsimp

lemma ExSet_subj_split_prod[φprogramming_base_simps, φsafe_simp]:
  ‹ (∃* x. A x 𝗌𝗎𝖻𝗃 (case x of (a,b) ⇒ P a b)) = (∃* a b. A (a,b) 𝗌𝗎𝖻𝗃 P a b) ›
  unfolding BI_eq_iff
  by clarsimp




paragraph ‹With Multiplicative Conjunction›

lemma ExSet_times_left [simp, φprogramming_base_simps, φsafe_simp]:
  "((∃* c. T c) * R) = (∃* c. T c * R )"
  by (simp add: BI_eq_iff, blast)

lemma ExSet_times_right[simp, φprogramming_base_simps, φsafe_simp]:
  "(L * (∃*c. T c)) = (∃* c. L * T c)"
  by (simp add: BI_eq_iff, blast)


paragraph ‹With Additive Disjunction›

lemma ExSet_addisj:
  ‹A + (∃*c. B c) ≡ ∃*c. A + B c›
  ‹(∃*c. B c) + A ≡ ∃*c. B c + A›
  unfolding atomize_eq BI_eq_iff
  by simp+


subsubsection ‹Transformation Rules›

lemma ExSet_transformation:
  ‹(⋀x. S x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗐𝗂𝗍𝗁 P)
⟹ ExSet S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExSet S' 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def by (clarsimp, blast)

lemma ExSet_transformation_I:
  ‹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗐𝗂𝗍𝗁 P
⟹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (ExSet S') 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def by (clarsimp, blast)

lemma ExSet_transformation_I_R:
  ‹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (ExSet S') 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def
  by (cases C; clarsimp, blast)


lemma ExSet_additive_disj:
  ‹(∃*x. A x + B x) = (∃*x. A x) + (∃*x. B x)›
  unfolding BI_eq_iff by (simp_all add: plus_fun) blast+

ML_file ‹library/tools/simproc_ExSet_expand_quantifier.ML›


subsubsection ‹ToA Reasoning›

lemma skolemize_transformation[φreason %ToA_fixes_quant]:
  "(⋀x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def by simp fastforce

lemma skolemize_transformation_R[φreason %ToA_fixes_quant+5]:
  "(⋀x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R x 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] ExSet R 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def REMAINS_def by (cases C; simp; blast)

lemma skolemize_transformation_tR[φreason %ToA_fixes_quant+5]:
  "(⋀x.  T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R x) 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] ExSet R) 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def REMAINS_def φTagA_def
  by (cases C; simp; blast)

lemma [φreason %ToA_fixes_quant]:
  "(⋀x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def by simp fastforce

lemma [φreason %ToA_fixes_quant+5]:
  "(⋀x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R x 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] ExSet R 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def by (cases C; simp; fastforce)

lemma [φreason %ToA_fixes_quant+5]:
  "(⋀x. T x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R x) 𝗐𝗂𝗍𝗁 P x)
⟹ ExSet T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] ExSet R) 𝗐𝗂𝗍𝗁 Ex P"
  unfolding Transformation_def φTagA_def
  by (cases C; simp; fastforce)

text ‹Continued in \ref{supp-ex-conj}›


subsection ‹Additive Conjunction›

definition Additive_Conj :: ‹'a BI ⇒ 'a BI ⇒ 'a BI› (infix "∧⇩B⇩I" 35)
  where ‹Additive_Conj = (∩)›

subsubsection ‹Basic Rules›

lemma Additive_Conj_expn[iff, φexpns]:
  ‹p ⊨ (A ∧⇩B⇩I B) ⟷ p ⊨ A ∧ p ⊨ B›
  unfolding Satisfaction_def Additive_Conj_def by simp

lemma additive_conj_inhabited_E[elim!]:
  ‹Satisfiable (A ∧⇩B⇩I B) ⟹ (Satisfiable A ⟹ Satisfiable B ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by simp blast

lemma [φreason %cutting]:
  ‹ A 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
⟹ B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
⟹ A ∧⇩B⇩I B 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P ∧ Q›
  unfolding Action_Tag_def 𝗋EIF_def
  by blast

lemma
  ‹ P 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A
⟹ Q 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 B
⟹ P ∧ Q 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 A ∧⇩B⇩I B›
  unfolding Action_Tag_def Satisfiable_def
  oops

text ‹There is no sufficiency reasoning for additive conjunction, because the sufficient condition
  of ‹A ∧⇩B⇩I B› cannot be reasoned separately (by considering ‹A› and ‹B› separately).›


subsubsection ‹Simplification›

paragraph ‹With ExSet›

lemma ExSet_adconj:
  ‹A ∧⇩B⇩I (∃*c. B c) ≡ ∃*c. A ∧⇩B⇩I B c›
  ‹(∃*c. B c) ∧⇩B⇩I A ≡ ∃*c. B c ∧⇩B⇩I A›
  unfolding atomize_eq BI_eq_iff
  by simp+


subsubsection ‹Transformation Rules›

text ‹Non-pure Additive Conjunction (excludes those are used in pure propositions), is rarely used under our
  refinement interpretation of BI assertions, because we can hardly imagine when and why an object
  has to be specified by two abstractions that cannot transform to each other (if they can,
  it is enough to use any one of them with a strong constraint over the abstraction, and transform it
  to the other when needed). We believe those abstractions if exist are specific enough to be preferably
  expressed by a specific φ-type equipped with ad-hoc reasoning rules.

  To support additive conjunction, it brings enormous branches in the reasoning so affects the
  reasoning performance. Before applying the rules introduced previously, we can add the following
  rules which are also attempted subsequently in order and applied whenever possible.
  ‹X ⟶ A ⟹ X ⟶ B ⟹ X ⟶ A ∧ B› generates two subgoals.
  ‹(A ⟶ Y) ∨ (B ⟶ Y) ⟹ A ∧ B ⟶ Y› branches the reasoning. Specially, when ‹Y ≡ ∃x. P x› is an
  existential quantification containing non-pure additive conjunction (e.g. ‹P x ≡ C x ∧ D x›),
  the priority of eliminating ‹∧› or instantiating ‹∃› is significant.
  We attempt the both priorities by a search branch.
(*  If we instantiate first, the instantiation is forced to be identical in the two branches.
  If we eliminate ‹∧› first, the ‹P› can be too strong *)
  This rule is irreversible and we recall our hypothesis that φ-types between the conjunction are
  considered disjoint, i.e., we only consider ‹(x ⦂ T) ∧ (y ⦂ U) ⟶ Y› when
  either ‹x ⦂ T ⟶ Y› or ‹y ⦂ U ⟶ Y›.
›

lemma [φreason %ToA_splitting]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P1
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P2
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A ∧⇩B⇩I B 𝗐𝗂𝗍𝗁 P1 ∧ P2 ›
  unfolding Transformation_def
  by simp

lemma NToA_conj_src_A:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ A ∧⇩B⇩I B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P ›
  unfolding Transformation_def
  by simp blast

lemma NToA_conj_src_B:
  ‹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ A ∧⇩B⇩I B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P ›
  unfolding Transformation_def
  by simp blast

text ‹Continued in \ref{supp-ex-conj}›


subsection ‹Subjection: Conjunction to a Pure Fact›

text ‹This is the only widely used additive conjunction under the interpretation of the φ data refinement›

subsubsection ‹Basic Rules›

lemma Subjection_inhabited_E[elim!]:
  ‹Satisfiable (S 𝗌𝗎𝖻𝗃 P) ⟹ (Satisfiable S ⟹ P ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by simp

lemma [φreason %cutting]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P ⟹ S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C)
⟹ S 𝗌𝗎𝖻𝗃 P 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P ∧ C ›
  unfolding Satisfiable_def Action_Tag_def Premise_def 𝗋EIF_def
  by simp

lemma [φreason %cutting]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P ⟹ C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S)
⟹ P ∧ C 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 S 𝗌𝗎𝖻𝗃 P ›
  unfolding Satisfiable_def Action_Tag_def Premise_def 𝗋ESC_def
  by simp 

lemma Subjection_imp_I:
  ‹ P
⟹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗐𝗂𝗍𝗁 Q
⟹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗌𝗎𝖻𝗃 P 𝗐𝗂𝗍𝗁 Q›
  unfolding Transformation_def by simp


subsubsection ‹Simplification›

lemma Subjection_cong:
  ‹P ≡ P' ⟹ (P' ⟹ S ≡ S') ⟹ (S 𝗌𝗎𝖻𝗃 P) ≡ (S' 𝗌𝗎𝖻𝗃 P')›
  unfolding atomize_eq BI_eq_iff by (simp, blast)

lemma Subjection_eq:
  ‹(A 𝗌𝗎𝖻𝗃 P) = (A' 𝗌𝗎𝖻𝗃 P) ⟷ (P ⟶ A = A')›
  unfolding BI_eq_iff
  by clarsimp blast

lemma Subjection_imp_simp[simp]:
  ‹ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗌𝗎𝖻𝗃 P 𝗐𝗂𝗍𝗁 Q) ⟷ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ∧ Q) ›
  unfolding Transformation_def by simp

lemma Subjection_True [simp, φprogramming_base_simps, φsafe_simp]:
  ‹(T 𝗌𝗎𝖻𝗃 True) = T›
  unfolding BI_eq_iff by simp

lemma Subjection_Flase[simp, φprogramming_base_simps, φsafe_simp]:
  ‹(T 𝗌𝗎𝖻𝗃 False) = 0›
  unfolding BI_eq_iff by simp

lemma Subjection_Subjection[simp, φprogramming_base_simps, φsafe_simp]:
  ‹(S 𝗌𝗎𝖻𝗃 P 𝗌𝗎𝖻𝗃 Q) = (S 𝗌𝗎𝖻𝗃 P ∧ Q)›
  unfolding BI_eq_iff
  by simp



lemma Subjection_Zero[simp, φprogramming_base_simps, φsafe_simp]:
  ‹(0 𝗌𝗎𝖻𝗃 P) = 0›
  unfolding BI_eq_iff
  by simp

lemma Subjection_transformation:
  ‹ S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗐𝗂𝗍𝗁 P
⟹ S 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S' 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P›
  unfolding Transformation_def by (simp; blast)

lemma Subjection_transformation_rewr:
  ‹ (A 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P) ⟷ (Q ⟶ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P))›
  unfolding Transformation_def by (simp; blast)

(* lemma (in φempty) [simp]: "(VAL (S 𝗌𝗎𝖻𝗃 P)) = (VAL S 𝗌𝗎𝖻𝗃 P)" by (simp add: φexpns set_eq_iff) blast
lemma (in φempty) [simp]: "(OBJ (S 𝗌𝗎𝖻𝗃 P)) = (OBJ S 𝗌𝗎𝖻𝗃 P)" by (simp add: φexpns set_eq_iff) *)

subparagraph ‹With Additive Conjunction›

lemma Subjection_addconj[simp, φprogramming_base_simps, φsafe_simp]:
  ‹(A 𝗌𝗎𝖻𝗃 P) ∧⇩B⇩I B ≡ (A ∧⇩B⇩I B) 𝗌𝗎𝖻𝗃 P›
  ‹B ∧⇩B⇩I (A 𝗌𝗎𝖻𝗃 P) ≡ (B ∧⇩B⇩I A) 𝗌𝗎𝖻𝗃 P›
  unfolding atomize_eq BI_eq_iff
  by (clarsimp; blast)+

subparagraph ‹With Additive Disjunction›

lemma Subjection_plus_distrib:
  ‹(A + B 𝗌𝗎𝖻𝗃 P) = (A 𝗌𝗎𝖻𝗃 P) + (B 𝗌𝗎𝖻𝗃 P)›
  unfolding BI_eq_iff
  by simp blast

subparagraph ‹With Multiplicative Conjunction›

lemma Subjection_times[simp, φprogramming_base_simps, φsafe_simp]:
  ‹(S 𝗌𝗎𝖻𝗃 P) * T = (S * T 𝗌𝗎𝖻𝗃 P)›
  ‹T * (S 𝗌𝗎𝖻𝗃 P) = (T * S 𝗌𝗎𝖻𝗃 P)›
  unfolding BI_eq_iff
  by (simp, blast)+

(*subsection ‹Disjunction›*)

(* Just similarly not needed

subsubsection ‹Embedding of disjunction in φ-Type›

definition φPlus :: " ('concrete, 'abs_a) φ ⇒ ('concrete, 'abs_b) φ ⇒ ('concrete, 'abs_a × 'abs_b) φ" (infixr "❙+" 55)
  where "A ❙+ B = (λ(a,b). B b + A a)"

lemma φPlus_expn[φexpns]:
  "c ∈ ((a,b) ⦂ A ❙+ B) ⟷ c ∈ (b ⦂ B) ∨ c ∈ (a ⦂ A)"
  unfolding φPlus_def φType_def by simp

lemma φPlus_expn':
  ‹((a,b) ⦂ A ❙+ B) = (b ⦂ B) + (a ⦂ A)›
  unfolding set_eq_iff by (simp add: φPlus_expn)
*)

subsubsection ‹Transformation Rules›

φreasoner_group ToA_subj = (%ToA_assertion_cut, [%ToA_assertion_cut, %ToA_assertion_cut+20]) for ‹T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P›
  ‹Transformation rules handling ‹Subjection››

lemma [φreason %ToA_subj]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (P ⟶ Q)
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def Premise_def
  by simp

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P ⟹
    T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def by simp

lemma [φreason %ToA_subj]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 (P ⟶ Q)
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 Q 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def Premise_def
  by simp

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ⟹
    T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗌𝗎𝖻𝗃 True 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def by simp

lemma [φreason %ToA_subj+10]: (*THINK: add Q in P, is good or not?*)
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ T 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗌𝗎𝖻𝗃 Q) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def φTagA_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+10]:
  ‹𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def Action_Tag_def
  by simp blast

lemma [φreason %ToA_subj+20]:
  "𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (T * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ (T 𝗌𝗎𝖻𝗃 Q) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 φTagA mode (U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗌𝗎𝖻𝗃 Q) 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def Premise_def φTagA_def Action_Tag_def
  by simp blast



subsection ‹Multiplicative Conjunction›

text ‹Is the \<^term>‹(*) :: ('a::sep_magma) BI ⇒ 'a BI ⇒ 'a BI› directly›

lemma set_mult_inhabited[elim!]:
  ‹Satisfiable (S * T) ⟹ (Satisfiable S ⟹ Satisfiable T ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by (simp, blast)

lemma [φreason %cutting]:
  ‹ X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A
⟹ Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 B
⟹ X * Y 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 A ∧ B›
  unfolding 𝗋EIF_def
  using set_mult_inhabited by blast

lemma
  ‹ A 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X
⟹ B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 Y
⟹ A ∧ B 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 X * Y›
  unfolding Action_Tag_def Satisfiable_def
  apply clarsimp
  oops

text ‹There is no sufficiency reasoning for multiplicative conjunction, because if we reason A and B
  separately, we loose the constraint about A and B are separatable, A ## B..›


lemma eq_left_frame:
  ‹ A = B ⟹ R * A = R * B ›
  by simp

lemma eq_right_frame:
  ‹ A = B ⟹ A * R = B * R ›
  by simp

lemma transformation_left_frame:
  "U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P ⟹ R * U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R * U 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast

lemma transformation_right_frame:
  "U' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P ⟹ U' * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U * R 𝗐𝗂𝗍𝗁 P "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast

lemma transformation_bi_frame:
  " R' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P
⟹ L' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 L 𝗐𝗂𝗍𝗁 Q
⟹ L' * R' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 L * R 𝗐𝗂𝗍𝗁 P ∧ Q "
  unfolding Transformation_def split_paired_All sep_conj_expn by blast


subsection ‹Finite Multiplicative Quantification (FMQ)›

definition Mul_Quant :: ‹('a ⇒ 'b::sep_algebra BI) ⇒ 'a set ⇒ 'b BI› ("✱")
  where ‹Mul_Quant A S ≡ (prod A S 𝗌𝗎𝖻𝗃 finite S)›

text ‹Finite Multiplicative Quantification ‹✱i∈I. A⇩i› is inductively applying separation conjunction
  over a finite family ‹{A⇩i}› of assertions indexed by ‹i∈I›, e.g., ‹(✱i∈I. A⇩i) = A⇩1 * A⇩2 * … * A⇩n› for
  ‹I = {1,2,…,n}››

syntax
  "_Mul_Quant" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(2✱(_/∈_)./ _)" [0, 51, 14] 14)
translations ― ‹Beware of argument permutation!›
  "✱i∈A. b" == "CONST Mul_Quant (λi. b) A"

syntax
  "_qMul_Quant" :: "pttrn ⇒ bool ⇒ 'a ⇒ 'a"  ("(2✱_ | (_)./ _)" [0, 0, 14] 14)
translations
  "✱x|P. t" => "CONST Mul_Quant (λx. t) {x. P}"


subsubsection ‹Rewrites›

lemma sep_quant_sing[simp, φsafe_simp]:
  ‹✱ A {i} = A i›
  unfolding Mul_Quant_def
  by simp

lemma sep_quant_empty[simp, φsafe_simp]:
  ‹✱ A {} = 1›
  unfolding Mul_Quant_def
  by simp

lemma sep_quant_insert:
  ‹i ∉ I ⟹ ✱ A (insert i I) = A i * ✱ A I›
  unfolding Mul_Quant_def
  by (clarsimp simp add: Subjection_eq)

lemma sep_quant_reindex:
  ‹ inj_on f I
⟹ ✱i∈f`I. A i ≡ ✱i∈I. A (f i)›
  unfolding Mul_Quant_def BI_eq_iff atomize_eq
  by (clarsimp; rule; clarsimp simp add: finite_image_iff prod.reindex_cong)

lemma finite_prod_subjection:
  ‹finite I ⟹ (∏i∈I. A i 𝗌𝗎𝖻𝗃 P i) = ((∏i∈I. A i) 𝗌𝗎𝖻𝗃 (∀i∈I. P i))›
  unfolding BI_eq_iff
proof (clarify; rule; clarsimp)
  fix u
  assume ‹finite I›
  have ‹u ⊨ (∏i∈I. A i 𝗌𝗎𝖻𝗃 P i) ⟶ u ⊨ prod A I ∧ (∀x∈I. P x)›
    by (induct arbitrary: u rule: finite_induct[OF ‹finite I›]; simp; blast)
  moreover assume ‹u ⊨ (∏i∈I. A i 𝗌𝗎𝖻𝗃 P i)›
  ultimately show ‹u ⊨ prod A I ∧ (∀x∈I. P x)›
    by blast
qed 

lemma sep_quant_subjection[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ‹(✱i∈I. A i 𝗌𝗎𝖻𝗃 P i) = ((✱i∈I. A i) 𝗌𝗎𝖻𝗃 (∀i∈I. P i))›
  unfolding BI_eq_iff
  by (clarify; rule; clarsimp simp add: Mul_Quant_def finite_prod_subjection)

lemma sep_quant_ExSet[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ‹(✱i∈I. ∃*j. A i j) = (∃*j. ✱i∈I. A i (j i))›
proof -
  have t1: ‹⋀u. finite I ⟹ u ⊨ (∏i∈I. ExSet (A i)) ⟷ (∃x. u ⊨ (∏i∈I. A i (x i)))› (is ‹⋀u. _ ⟹ ?goal u›)
  proof -
    fix u
    assume ‹finite I›
    show ‹?goal u›
      apply (induct arbitrary: u rule: finite_induct[OF ‹finite I›]; clarsimp)
      apply (rule; clarsimp)
      subgoal for x F xa ua v xb
        by (rule exI[where x=‹λi. if i = x then xa else xb i›], rule exI[where x=ua], rule exI[where x=v],
            simp, smt (verit) prod.cong)
      by blast
  qed
  show ?thesis
    unfolding BI_eq_iff Mul_Quant_def
    by (clarsimp; rule; clarsimp simp add: t1)
qed

lemma sep_quant_swap:
  ‹⟦ finite I; finite J ⟧ ⟹(✱i∈I. ✱j∈J. A i j) = (✱j∈J. ✱i∈I. A i j)›
  unfolding BI_eq_iff Mul_Quant_def
  by (clarsimp; metis prod.swap)

lemma sep_quant_scalar_assoc:
  ‹(✱i∈I. ✱j∈J. A i j) = ((✱(i,j) ∈ I × J. A i j) 𝗌𝗎𝖻𝗃 finite I)›
  unfolding BI_eq_iff Mul_Quant_def
  by (clarsimp; rule;
      clarsimp simp add: finite_prod_subjection ex_in_conv finite_cartesian_product_iff;
      cases ‹I = {}›; cases ‹J = {}›; simp add: prod.cartesian_product)

lemma sep_quant_sep:
  ‹(✱i∈I. A i) * (✱i∈I. B i) = (✱i∈I. A i * B i)›
  unfolding BI_eq_iff Mul_Quant_def
  proof (clarsimp; rule; clarify)
    fix u ua v
    assume ‹finite I›
    show ‹ua ⊨ prod A I ⟹ v ⊨ prod B I ⟹ ua ## v ⟹ ua * v ⊨ (∏i∈I. A i * B i)›
      by (induct arbitrary: v u ua rule: finite_induct[OF ‹finite I›] ; clarsimp ;
          smt (verit, best) sep_disj_commuteI sep_disj_multD1 sep_disj_multI1 sep_mult_assoc sep_mult_commute)
  next
    fix u
    assume ‹finite I›
    show ‹u ⊨ (∏i∈I. A i * B i) ⟹ ∃ua v. u = ua * v ∧ ua ⊨ prod A I ∧ v ⊨ prod B I ∧ ua ## v›
      by (induct arbitrary: u rule: finite_induct[OF ‹finite I›] ; clarsimp ;
          smt (verit) sep_disj_commuteI sep_disj_multD1 sep_disj_multI1 sep_mult_assoc sep_mult_commute)
qed

lemma sep_quant_merge_additive_disj:
  ‹(✱i∈I. A i) + (✱i∈I. B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i + B i)›
  ― ‹but not held reversely›
unfolding Transformation_def Mul_Quant_def
proof (clarsimp; rule; clarsimp)
  fix v
  assume ‹finite I›
  show ‹v ⊨ prod A I ⟹ v ⊨ (∏i∈I. A i + B i)›
    by (induct arbitrary: v rule: finite_induct[OF ‹finite I›]; clarsimp; blast)
next
  fix v
  assume ‹finite I›
  show ‹v ⊨ prod B I ⟹ v ⊨ (∏i∈I. A i + B i)›
    by (induct arbitrary: v rule: finite_induct[OF ‹finite I›]; clarsimp; blast)
qed

lemma sep_quant_scalar_distr:
  ‹I ∩ J = {} ⟹ (✱i∈I. A i) * (✱j∈J. B j) = (✱k∈I + J. (if k ∈ J then B k else A k))› (*TODO: syntax priority!*)
  unfolding Mul_Quant_def plus_set_def Subjection_times Subjection_Subjection
  by (clarsimp simp add: Subjection_eq,
      smt (verit) disjoint_iff prod.cong prod.union_disjoint)


subsubsection ‹Basic Rules›

lemma [φreason %cutting]:
  ‹ (⋀i∈S. A i 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P i)
⟹ (✱i∈S. A i) 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 (∀i∈S. P i) ›
  unfolding Mul_Quant_def Action_Tag_def Satisfiable_def meta_Ball_def Premise_def 𝗋EIF_def
  by (clarsimp; metis Satisfaction_def ex_in_conv prod_zero zero_set_iff)


subsubsection ‹Transformation›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  ‹ A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈{x}. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈{}. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ A x * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈{x}. A i) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈{}. A i) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈{x}. A i) 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈{}. A i) 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈{x}. A i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈{}. A i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  by simp


paragraph ‹Weak Normalization›

text ‹Source side is normalized by merging separations together
        ‹(✱i∈I. A i) * (✱i∈I. B i) ⟶ (✱i∈I. A i * B i)›
  while the target side is normalized by splitting sep-quants into small separations
        ‹(✱i∈I. A i * B i) ⟶ (✱i∈I. A i) * (✱i∈I. B i)›.
  It is because our reasoning strategy is splitting the target side first and scanning the source
    side φ-type-by-type for each separated individual ‹φ›-type items.
  The first step works in assertion form while the second step is between φ-types.
  The ‹✱› is in assertion level, so the target side has to be split before the first step.
  Before the second step, for each individual target item ‹(✱i∈I. x ⦂ T)› we shall apply
    ‹sep_quant_transformation› to strip off the outer ‹✱› in order to enter inside into φ-type level
    so that the second step can continue.
  This ‹sep_quant_transformation› may fail and if it fails, there is no way to enter the second step
    ∗‹in this unfinished reasoning mechanism right now›.

  Later after the type embedding of ‹✱› is completed, the reasoning of ‹✱› will be forwarded to the
  type embedding which provides full power of competence on that level.
›

lemma [φreason %ToA_weak_red]:
  ‹ (✱i∈I. A i * B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈I. A i) * (✱i∈I. B i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  ‹ (✱i∈I. A i * B i) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (✱i∈I. A i) * (✱i∈I. B i) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  unfolding sep_quant_sep[symmetric]
  by (simp add: mult.assoc)

lemma [φreason %ToA_weak_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i) * (✱i∈I. B i) 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i * B i) 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i) * (✱i∈I. B i) * R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i * B i) * R 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_sep
  by simp

lemma [φreason %ToA_weak_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i) * (✱i∈I. B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. A i * B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_sep
  by simp




paragraph ‹Transformation Functor›

lemma sep_quant_transformation[φreason %ToA_cut]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 I = J
⟹ (⋀i∈I. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗐𝗂𝗍𝗁 P i)
⟹ (✱i∈I. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈J. B i) 𝗐𝗂𝗍𝗁 (∀i∈I. P i) ›
  unfolding Transformation_def Mul_Quant_def meta_Ball_def Premise_def 𝗋Guard_def
  proof clarsimp
    fix v
    assume ‹finite J›
    show ‹ (⋀x. x ∈ J ⟹ ∀v. v ⊨ A x ⟶ v ⊨ B x ∧ P x)
        ⟹ v ⊨ prod A J ⟹ v ⊨ prod B J ∧ (∀x∈J. P x) › 
      by (induct arbitrary: v rule: finite_induct[OF ‹finite J›]; clarsimp; blast)
  qed


lemma [φreason %ToA_cut]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 I = J
⟹ (⋀i∈J. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R i 𝗐𝗂𝗍𝗁 P i)
⟹ (✱i∈I. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈J. B i) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] (✱i∈J. R i) 𝗐𝗂𝗍𝗁 (∀i∈J. P i) ›
  unfolding REMAINS_def Premise_def 𝗋Guard_def
  by (cases C; simp add: sep_quant_sep sep_quant_transformation)


paragraph ‹Scalar Associative›

lemma [φreason %ToA_normalizing]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 finite I ⟹ (✱(i,j) ∈ I × J. A i j) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
⟹ (✱i∈I. ✱j∈J. A i j) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_scalar_assoc Premise_def Subjection_transformation_rewr
  by simp

lemma [φreason %ToA_normalizing]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 finite I ⟹ (✱(i,j) ∈ I × J. A i j) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
⟹ (✱i∈I. ✱j∈J. A i j) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_scalar_assoc Premise_def Subjection_transformation_rewr Subjection_times
  by simp

lemma [φreason %ToA_normalizing]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱(i,j) ∈ I × J. B i j) 𝗐𝗂𝗍𝗁 P
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite I
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. ✱j∈J. B i j) 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_scalar_assoc Premise_def
  by simp

lemma [φreason %ToA_normalizing]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱(i,j) ∈ I × J. B i j) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite I
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. ✱j∈J. B i j) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  unfolding sep_quant_scalar_assoc Premise_def
  by simp





subsection ‹Universal Quantification›

definition AllSet :: ‹('a ⇒ 'b BI) ⇒ 'b BI› (binder "∀⇩B⇩I" 10)
  where ‹AllSet X = {y. ∀x. y ∈ X x}›

lemma AllSet_expn[simp, φexpns]:
  ‹p ⊨ (∀⇩B⇩Ix. B x) ⟷ (∀x. p ⊨ B x)›
  unfolding AllSet_def Satisfaction_def by simp

lemma AllSet_subset:
  ‹A ⊆ (∀⇩B⇩I x. B x) ⟷ (∀x. A ⊆ B x)›
  unfolding AllSet_def subset_iff by (rule; clarsimp; blast)

lemma AllSet_refl:
  ‹(⋀x. refl (B x))
⟹ refl (∀⇩B⇩I x. B x)›
  unfolding AllSet_def
  by (simp add: refl_on_def)

lemma AllSet_trans:
  ‹(⋀x. trans (B x))
⟹ trans (∀⇩B⇩I x. B x)›
  unfolding AllSet_def
  by (smt (verit) mem_Collect_eq transD transI)

lemma BI_All_comm:
  ‹(∀⇩B⇩I x y. A x y) = (∀⇩B⇩I y x. A x y)›
  unfolding BI_eq_iff
  by (simp, blast)

lemma [elim!]:
  ‹Satisfiable (AllSet S) ⟹ (Satisfiable (S x) ⟹ C) ⟹ C›
  unfolding Satisfiable_def
  by clarsimp blast

lemma [φinhabitance_rule 1000]:
  ‹ S x 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C
⟹ AllSet S 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C ›
  unfolding Action_Tag_def 𝗋EIF_def
  by clarsimp blast


subsection ‹Supplementary Connective›

subsubsection ‹World Shift› ― ‹Functional refinement in assertion-level, functional counterpart of ‹⨾››

definition World_Shift :: ‹('c ⇒ 'd) ⇒ 'c BI ⇒ 'd BI› ("Ψ[_]" [10] 1000)
  where ‹(Ψ[ψ] S) = {ψ u |u. u ⊨ S}›
  ― ‹applying a function ‹ψ› (usually a homomorphism) to the concrete objects (namely Kripke world)
      characterized by an assertion.›

text ‹Some thinking, what if we extend ‹ψ› to be a relation instead of a function? Then ‹Ψ[ψ]›
  actually becomes the assertion-level counterpart of the φ-type ‹⨾›. However, the difficulty is
  I cannot find the relational extension of closed homomorphism that gives us distributivity over
  ‹*› like ‹Ψ_Multiplicative_Conj›.›

lemma World_Shift_expn[φexpns, simp]:
  ‹p ⊨ Ψ[ψ] S ⟷ (∃u. p = ψ u ∧ u ⊨ S)›
  unfolding World_Shift_def Satisfaction_def
  by clarsimp

lemma World_Shift_expn'[φexpns, simp]:
  ‹p ∈ Ψ[ψ] S ⟷ (∃u. p = ψ u ∧ u ⊨ S)›
  unfolding World_Shift_def Satisfaction_def
  by clarsimp

text ‹The motivation of such modality is it is used later in Domainoid Extraction›

paragraph ‹Rewrites \& Transformations›

lemma Ψ_1:
  ‹ homo_one ψ
⟹ Ψ[ψ] 1 = 1 ›
  unfolding BI_eq_iff homo_one_def
  by simp

lemma Ψ_0:
  ‹ Ψ[ψ] 0 = 0 ›
  unfolding BI_eq_iff
  by clarsimp

lemma
  ‹ Ψ[ψ] (A ∧⇩B⇩I B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (Ψ[ψ] A ∧⇩B⇩I Ψ[ψ] B) ›
  unfolding Transformation_def
  by (clarsimp; blast)

lemma Ψ_Multiplicative_Conj:
  ‹ closed_homo_sep ψ
⟹ Ψ[ψ] (A * B) = Ψ[ψ] A * Ψ[ψ] B›
  unfolding BI_eq_iff
  by (clarsimp simp add: closed_homo_sep_def closed_homo_sep_disj_def homo_sep_def
                         homo_sep_mult_def; rule; clarsimp; metis)

lemma Ψ_Mul_Quant:
  ‹ closed_homo_sep ψ
⟹ homo_one ψ
⟹ Ψ[ψ] (✱i∈S. A i) = (✱i∈S. Ψ[ψ] (A i)) ›
proof -
  assume ‹closed_homo_sep ψ› and ‹homo_one ψ›
  { assume ‹finite S›
    have ‹Ψ[ψ] (∏i∈S. A i) = (∏i∈S. Ψ[ψ] (A i))›
      by (induct rule: finite_induct[OF ‹finite S›];
          simp add: Ψ_1 ‹closed_homo_sep ψ› ‹homo_one ψ› Ψ_Multiplicative_Conj)
  }
  then show ‹Ψ[ψ] (✱i∈S. A i) = (✱i∈S. Ψ[ψ] (A i))›
    unfolding Mul_Quant_def
    by (smt (verit, best) Subjection_Flase Subjection_True Ψ_0)
qed

lemma Ψ_Additive_Disj:
  ‹Ψ[d] (A + B) = Ψ[d] A + Ψ[d] B›
  unfolding BI_eq_iff
  by (clarsimp; metis)

lemma Ψ_ExSet:
  ‹Ψ[d] (∃*c. S c) = (∃*c. Ψ[d] (S c))›
  unfolding BI_eq_iff
  by (clarsimp; metis)

lemma Ψ_Subjection:
  ‹Ψ[d] (S 𝗌𝗎𝖻𝗃 P) = (Ψ[d] S 𝗌𝗎𝖻𝗃 P)›
  unfolding BI_eq_iff
  by (clarsimp; metis)


section ‹Basic φ-Types \& Embedding of Logic Connectives›

subsection ‹Identity φ-Type›

definition Itself :: " ('a,'a) φ " where "Itself x = {x}"

lemma Itself_expn[φexpns, iff]:
  "p ⊨ (x ⦂ Itself) ⟷ p = x"
  unfolding φType_def Itself_def Satisfaction_def by auto

lemma Itself_inhabited_E[elim!]:
  ‹ Satisfiable (x ⦂ Itself) ⟹ C ⟹ C › .

lemma Itself_inhabited[φreason %cutting, simp, intro!]:
  ‹ Satisfiable (x ⦂ Itself) ›
  unfolding Satisfiable_def
  by blast

lemma [φreason %cutting]:
  ‹ Abstract_Domain Itself (λ_. True) ›
  unfolding Abstract_Domain_def 𝗋EIF_def Satisfiable_def
  by clarsimp

lemma [φreason %abstract_domain]:
  ‹ Abstract_Domain⇩L Itself (λ_. True) ›
  unfolding Abstract_Domain⇩L_def 𝗋ESC_def Satisfiable_def
  by simp

lemma Itself_E:
  ‹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 v ⊨ (x ⦂ T) ⟹ v ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T ›
  unfolding Transformation_def Premise_def by simp

text ‹The introduction rule of Itself cannot be written in such ∃free-ToA form but in To-Transformation form.›

lemma satisfication_encoding:
  ‹ (x ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T 𝗐𝗂𝗍𝗁 P) ⟷ x ⊨ (y ⦂ T) ∧ P ›
  unfolding Transformation_def by simp


subsubsection ‹Construction from Raw Abstraction represented by Itself ›
  ― ‹is a sort of reasoning process useful later in making initial Hoare triples from semantic raw
      representation (which are represented by Itself, i.e., no abstraction).›

φreasoner_group abstract_from_raw = (100, [16, 1399]) for ‹v ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T›
      > ToA_bottom and < ToA_splitting_target
      ‹Rules constructing abstraction from raw representations›
  and abstract_from_raw_cut = (1000, [1000, 1030]) for ‹v ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T› in abstract_from_raw
      ‹Cutting rules constructing abstraction from raw representations›
  and derived_abstract_from_raw = (70, [60,80]) for ‹v ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T›
                                                 in abstract_from_raw and < abstract_from_raw_cut
      ‹Derived rules›

declare [[φreason_default_pattern
      ‹ _ ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 › ⇒ ‹ _ ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 › (1120)
  and ‹ _ ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 › ⇒ ‹ _ ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 › (1110)
]]

declare Itself_E[φreason default %ToA_falling_latice]

lemma [φreason default %ToA_falling_latice+1 except ‹?var ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ @tag 𝒯𝒫›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 c = c' ⟹ c' ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A)
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 c = c'
⟹ c ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A ›
  unfolding Premise_def
  by simp

lemma [φreason %abstract_from_raw_cut]:
  ‹ c⇩a ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A
⟹ c⇩b ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 c⇩a ## c⇩b
⟹ (c⇩a * c⇩b) ⦂ Itself 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A * B›
  unfolding Transformation_def Premise_def
  by (clarsimp; blast)

subsection ‹Embedding of ‹⊤››

definition φAny :: ‹('c, 'x) φ› ("⊤⇩φ") where ‹⊤⇩φ = (λ_. UNIV)›

setup ‹Sign.mandatory_path "φAny"›

lemma unfold [φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ‹(x ⦂ ⊤⇩φ) = UNIV›
  unfolding φAny_def φType_def ..

lemma expansion[simp]:
  ‹p ⊨ (x ⦂ ⊤⇩φ) ⟷ True›
  unfolding φAny.unfold
  by simp

setup ‹Sign.parent_path›

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  ‹x ⦂ ⊤⇩φ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 True›
  unfolding 𝗋EIF_def
  by simp

lemma [φreason %extract_pure]:
  ‹True 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ ⊤⇩φ›
  unfolding 𝗋ESC_def Satisfiable_def
  by simp

subsubsection ‹Transformation Rules›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ ⊤⇩φ 𝗐𝗂𝗍𝗁 P›
  unfolding φAny.unfold
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ ⊤⇩φ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  unfolding φAny.unfold
  by simp

paragraph ‹Separation Extraction›

text ‹In ToA, the ‹⊤⇩φ› behaviors like a wildcard that can absorb an undetermined number of φ-type items,
  and which φ-type items are absorbed cannot be determined just from the type information. Therefore,
  we require explicit annotations to be given to give the range of the absorption of ‹⊤⇩φ›.

TODO: make such annotation syntax.
›

lemma [φreason %ToA_top+1]:
  ‹ May_Assign (snd x) unspec
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((), unspec) ⦂ ⊤⇩φ ∗[False] ⊤⇩φ ›
  unfolding Transformation_def
  by clarsimp

(*
lemma [φreason %ToA_top]:
  ‹x ⦂ T ∗[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (unspec, snd x) ⦂ ⊤⇩φ ∗[C] W ›
  unfolding Transformation_def
  by clarsimp blast*)

subsection ‹Embedding of ‹⊥››

definition φBot :: ‹('c,'a) φ› ("⊥⇩φ") where ‹⊥⇩φ = (λ_. 0)›

setup ‹Sign.mandatory_path "φBot"›

lemma unfold[φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ‹(x ⦂ ⊥⇩φ) = 0›
  unfolding φBot_def φType_def ..

lemma expansion[simp]:
  ‹p ⊨ (x ⦂ ⊥⇩φ) ⟷ False›
  unfolding φBot.unfold
  by simp

setup ‹Sign.parent_path›

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  ‹x ⦂ ⊥⇩φ 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 False ›
  unfolding 𝗋EIF_def φBot.unfold Satisfiable_def
  by simp

lemma [φreason %extract_pure]:
  ‹False 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ ⊥⇩φ›
  unfolding 𝗋ESC_def φBot.unfold Satisfiable_def
  by simp

subsubsection ‹Transformation Rules›

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  ‹ 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ⊥⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  unfolding φBot.unfold
  by simp

lemma [φreason %ToA_red]:
  ‹ 0 * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x ⦂ ⊥⇩φ) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  unfolding φBot.unfold
  by simp

paragraph ‹Separation Extraction›

(*TODO: more think!*)

lemma [φreason %ToA_top]:
  ‹ May_Assign (snd x) unspec
⟹ x ⦂ ⊥⇩φ ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any, unspec) ⦂ U ∗[False] ⊤⇩φ ›
  unfolding Transformation_def
  by clarsimp


subsection ‹Embedding of Separation Conjunction›

lemma φProd_expn' [φprogramming_base_simps, φprogramming_simps, φsafe_simp]:
  ‹((a,b) ⦂ A ∗ B) = (a ⦂ A) * (b ⦂ B)›
  unfolding BI_eq_iff by (simp add: set_mult_expn) blast

lemma φProd_expn'':
  ‹ NO_MATCH (xx,yy) x
⟹ (x ⦂ A ∗ B) = (fst x ⦂ A) * (snd x ⦂ B)›
  unfolding BI_eq_iff by (cases x; simp add: set_mult_expn) blast

bundle φProd_expn = φProd_expn'[simp] φProd_expn''[simp]

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  ‹ fst x ⦂ T1 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C1
⟹ snd x ⦂ T2 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C2
⟹ x ⦂ T1 ∗ T2 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C1 ∧ C2›
  unfolding Satisfiable_def Action_Tag_def 𝗋EIF_def
  by (cases x; simp, blast)

paragraph ‹Frame Rules›

lemma transformation_right_frame_ty:
  ‹(⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = fst x ⟹ a ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a) ⦂ U 𝗐𝗂𝗍𝗁 P(a))
⟹ x ⦂ T ∗ R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apfst f x ⦂ U ∗ R 𝗐𝗂𝗍𝗁 P(fst x) ›
  unfolding Transformation_def
  by (cases x; clarsimp; blast)

lemma transformation_left_frame_ty:
  ‹(⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = snd x ⟹ a ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a) ⦂ U 𝗐𝗂𝗍𝗁 P(a))
⟹ x ⦂ R ∗ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apsnd f x ⦂ R ∗ U 𝗐𝗂𝗍𝗁 P(snd x) ›
  unfolding Transformation_def
  by (cases x; clarsimp; blast)

subsubsection ‹Abstract Domain›

text ‹The upper bound of the abstraction domain is simple.›
(*
lemma ― ‹will be derived later›:
  ‹ Abstract_Domain T D⇩T
⟹ Abstract_Domain U D⇩U
⟹ Abstract_Domain (T ∗ U) (λ(x,y). D⇩T x ∧ D⇩U y) ›
  unfolding Abstract_Domain_def Action_Tag_def Satisfiable_def
  by (clarsimp, blast)
*)

text ‹However, the lower bound is non-trivial, in which case we have to show the separation combination
  is compatible between the two φ-types. The compatibility is encoded by predicate ‹Separation_Disj⇩ψ›
  and ‹Separation_Disj⇩φ› which are solved by means of the domainoid introduced later.
  So the rules are given until \cref{phi-types/Domainoid/App}.
›


subsubsection ‹Transformation Rules›

lemma destruct_φProd_φapp: (*TODO: merge this into general destruction*)
  ‹x ⦂ T ∗ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst x ⦂ T) * (snd x ⦂ U)›
  by (cases x; simp add: Transformation_def set_mult_expn) blast

lemma φProd_transformation:
  " x ⦂ N 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x' ⦂ N' 𝗐𝗂𝗍𝗁 Pa
⟹ y ⦂ M 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ M' 𝗐𝗂𝗍𝗁 Pb
⟹ (x,y) ⦂ N ∗ M 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x',y') ⦂ N' ∗ M' 𝗐𝗂𝗍𝗁 Pa ∧ Pb"
  unfolding Transformation_def by simp blast
  (*The rule is not added into the φ-LPR because such product is solved by Structural Extract*)

paragraph ‹Reduction›

lemma [φreason %ToA_red]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst x ⦂ N) * (snd x ⦂ M) 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ N ∗ M 𝗐𝗂𝗍𝗁 P"
  by (cases x; simp add: φProd_expn')

lemma [φreason %ToA_red+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_,_) ⦂ _ ∗ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                              ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ _ ∗ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x ⦂ N) * (y ⦂ M) 𝗐𝗂𝗍𝗁 P
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x,y) ⦂ N ∗ M 𝗐𝗂𝗍𝗁 P"
  by (simp add: φProd_expn')

text ‹The reductions on source are not enabled as they may break the form of original source assertion›

paragraph ‹Separation Extraction›

text ‹see §‹Technical φ-Types required in Reasoning Transformation/Separation Extraction of ‹φ›Prod››

lemma Structural_Extract_φProd_a [φreason %ToA_cut except ‹(_ :: ?'a::sep_semigroup set) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
      ― ‹merely the rule for non-semigroup algebras.
          for others, see §‹Technical φ-Types required in Reasoning Transformation/Separation Extraction of ‹φ›Prod››
  ‹ fst a ⦂ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b ⦂ Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ a ⦂ A ∗[True] X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((b, snd a), unspec) ⦂ (Y ∗ X) ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫' ›
  unfolding Action_Tag_def Transformation_def
  by clarsimp blast


subsection ‹Embedding of Conditioned Separation Conjunction›

lemma Cond_φProd_expn:
  ‹ (x ⦂ T ∗[C] U) = (if C then (x ⦂ T ∗ U) else (fst x ⦂ T)) ›
  unfolding Cond_φProd_def φType_def
  by clarsimp

lemma Cond_φProd_expn_const[simp, φprogramming_base_simps, φsafe_simp]:
  ‹T ∗[True] U ≡ T ∗ U›
  ‹x ⦂ T ∗[False] U ≡ fst x ⦂ T›
  by (simp_all add: Cond_φProd_def φType_def)

subsubsection ‹Basic Rules›

lemma [φreason %extract_pure]:
  ‹ fst x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ snd x ⦂ U 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q)
⟹ x ⦂ T ∗[C] U 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P ∧ (C ⟶ Q) ›
  unfolding Satisfiable_def 𝗋EIF_def
  by (cases C; clarsimp; blast)

paragraph ‹Frame Rules›

lemma transformation_right_frame_conditioned_ty:
  ‹(⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = fst x ⟹ a ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a) ⦂ U 𝗐𝗂𝗍𝗁 P(a))
⟹ x ⦂ T ∗[C] R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apfst f x ⦂ U ∗[C] R 𝗐𝗂𝗍𝗁 P(fst x) ›
  unfolding Transformation_def
  by (cases C; cases x; clarsimp; blast)

lemma transformation_left_frame_conditioned_ty:
  ‹(⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 a = snd x ⟹ a ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f(a) ⦂ U 𝗐𝗂𝗍𝗁 P(a))
⟹ x ⦂ R ∗[C] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 apsnd f x ⦂ R ∗[C] U 𝗐𝗂𝗍𝗁 C ⟶ P(snd x) ›
  unfolding Transformation_def
  by (cases C; cases x; clarsimp; blast)


subsubsection ‹Transformation Rules›

text ‹see §‹Reasoning/Supplementary Transformations/Type-embedding of Conditioned Remains››


subsection ‹Embedding of Empty›

definition φNone :: ‹('v::one, unit) φ› ("○")
  where ‹φNone = (λx. { 1 }) ›

lemma φNone_expn[φexpns, simp]:
  ‹p ⊨ (x ⦂ φNone) ⟷ p = 1›
  unfolding φNone_def φType_def Satisfaction_def
  by simp

lemma φNone_inhabited[elim!]:
  ‹Satisfiable (x ⦂ φNone) ⟹ C ⟹ C› .

subsubsection ‹Rewrites›

lemma φNone_itself_is_one[simp, φsafe_simp]:
  ‹(any ⦂ φNone) = 1›
  unfolding BI_eq_iff by simp

lemma φProd_φNone:
  ‹((x',y) ⦂ ○ ∗ U) = ((y ⦂ U) :: 'a::sep_magma_1 BI)›
  ‹((x,y') ⦂ T ∗ ○) = ((x ⦂ T) :: 'b::sep_magma_1 BI)›
  unfolding BI_eq_iff
  by (simp_all add: set_mult_expn)


subsubsection ‹Transformation Rules›

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any ⦂ ○) * X 𝗐𝗂𝗍𝗁 P "
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_red]:
  " H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ H 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (any ⦂ ○) * X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_red]:
  " R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ (any ⦂ ○) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P "
  for X :: ‹'a::sep_magma_1 BI›
  unfolding mult_1_left φNone_itself_is_one .

lemma [φreason %ToA_success]:
  ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 any ⦂ ○ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] X›
  for X :: ‹'a::sep_magma_1 BI›
  unfolding REMAINS_def Action_Tag_def by simp

lemma [φreason %ToA_success+1]:
  ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 () ⦂ ○ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] X›
  for X :: ‹'a::sep_magma_1 BI›
  unfolding REMAINS_def Action_Tag_def by simp

(*
lemma [φreason 1200]:
  ‹any ⦂ φNone 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 ⦂ Itself›
  unfolding Transformation_def by simp *)

(*subsubsection ‹Insertion into Unital Algebra›

definition φOption_Insertion :: ‹('v, 'x) φ ⇒ ('v option, 'x option) φ› ("◒ _" [91] 90)
  where ‹◒ T = (λx. case x of Some x' ⇒ { Some v |v. v ∈ (x' ⦂ T) } | None ⇒ { None })›

lemma φOption_Insertion_expn[simp, φexpns]:
  ‹ p ⊨ (x' ⦂ ◒ T) ⟷ (case x' of None ⇒ p = None
                                 | Some x ⇒ ∃v. p = Some v ∧ v ⊨ (x ⦂ T)) ›
  unfolding φOption_Insertion_def φType_def Satisfaction_def
  by (cases x'; clarsimp)+

lemma [φreason 1000]:
  ‹ (⋀x. x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P x)
⟹ x ⦂ ◒ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 pred_option P x›
  unfolding Action_Tag_def Satisfiable_def
  by (cases x; clarsimp)

lemma [φreason 1000]:
  ‹ (⋀x. P x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ T)
⟹ pred_option P x 𝗌𝗎𝖿𝖿𝗂𝖼𝖾𝗌 x ⦂ ◒ T›
  unfolding Action_Tag_def Satisfiable_def
  by (cases x; clarsimp)
*)

subsection ‹Injection into Unital Algebra›

definition φSome :: ‹('v, 'x) φ ⇒ ('v option, 'x) φ› ("● _" [91] 90)
  where ‹● T = (λx. { Some v |v. v ∈ (x ⦂ T) })›

lemma φSome_expn[simp, φexpns]:
  ‹p ⊨ (x ⦂ ● T) ⟷ (∃v. p = Some v ∧ v ⊨ (x ⦂ T))›
  unfolding φType_def φSome_def Satisfaction_def
  by simp

subsubsection ‹Rewrites›

lemma φSome_φProd:
  ‹ ● T ∗ ● U = ● (T ∗ U) ›
  by (rule φType_eqI; clarsimp; force)

lemma φSome_eq_term_strip:
  ‹ (x ⦂ ● T) = (y ⦂ ● U) ≡ (x ⦂ T) = (y ⦂ U) ›
  unfolding atomize_eq BI_eq_iff
  by clarsimp blast
  


subsubsection ‹Transformation Rules›

lemma φSome_transformation_strip:
  ‹ x ⦂ ● T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U 𝗐𝗂𝗍𝗁 P ≡ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P ›
  unfolding atomize_eq Transformation_def
  by clarsimp blast

lemma [φreason %ToA_cut]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ● T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U 𝗐𝗂𝗍𝗁 P ›
  unfolding φSome_transformation_strip .

lemma [φreason %ToA_cut]:
  ‹ x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ● T ∗[Cw] ● W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U ∗[Cr] ● R 𝗐𝗂𝗍𝗁 P›
  by (cases Cw; cases Cr; simp add: φSome_φProd φSome_transformation_strip)

subsubsection ‹Properties› ― ‹Some properties have to be given early before derivers ready›

lemma Abstract_Domain_φSome[φreason %abstract_domain]:
  ‹ Abstract_Domain T D
⟹ Abstract_Domain (● T) D ›
  unfolding Abstract_Domain_def 𝗋EIF_def Satisfiable_def
  by clarsimp


subsection ‹Technical φ-Types required in Reasoning Transformation›

subsubsection ‹Variant of Empty φ-Type for Arbitrary Abstract Objects›

definition φNone_freeobj :: ‹('v::one, 'x) φ› ("○⇩𝗑") where ‹○⇩𝗑 = (λx. 1)›

lemma φNone_freeobj_expn[φexpns, simp, φsafe_simp]:
  ‹ (x ⦂ ○⇩𝗑) = 1›
  unfolding φType_def φNone_freeobj_def
  by simp

lemma φSome_φNone_freeobj:
  ‹ x ⦂ T ∗ ○⇩𝗑 ≡ fst x ⦂ T›
  ‹ y ⦂ ○⇩𝗑 ∗ T ≡ snd y ⦂ T›
  ‹ x' ⦂ ○⇩𝗑 ∗ (○⇩𝗑 :: ('v::sep_magma_1, 'x) φ) ≡ 1›
  for T :: ‹'b ⇒ 'a::sep_magma_1 set›
  unfolding atomize_eq BI_eq_iff
  by ((rule φType_eqI)?; clarsimp)+

subsubsection ‹Conditioned Product at Left›

definition LeftCond_φProd :: ‹ ('v,'x) φ ⇒ bool ⇒ ('v,'y) φ ⇒ ('v::sep_magma,'x × 'y) φ › ("_ [_]∗ _" [69,20,70] 68)
  where ‹(T [C⇩T]∗ U) ≡ if C⇩T then T ∗ U else (λx. snd x ⦂ U)›

lemma LeftCond_φProd_expn[φexpns, simp]:
  ‹ c ⊨ (x ⦂ T [C⇩T]∗ U) ⟷ (if C⇩T then c ⊨ (x ⦂ T ∗ U) else c ⊨ (snd x ⦂ U))›
  unfolding LeftCond_φProd_def φType_def
  by (cases C⇩T; clarsimp)

lemma LeftCond_single_Cond_const_red[simp, φsafe_simp]:
  ‹ T [True]∗ U = T ∗ U ›
  by (rule φType_eqI, clarsimp)+


subsubsection ‹Conditional Insertion into Unital Algebra›

text ‹This section we give an equivalent representation ‹● T ∗ ◒[C] R› of the conditioned separation \<^term>‹T ∗[C] R›.
  ‹◒› is convenient to specify element-wise existence, and makes it easy to merge two conditioned remainders

  ‹ (fst a, wy) ⦂ A ∗[Cy] WY 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b ⦂ Y ∗[Cb] B 𝗐𝗂𝗍𝗁 P1 
⟹ (snd b, wx) ⦂ ◒[Cb] B ∗ ◒[Cx] WX 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 c ⦂ ● X ∗ ◒[Cr] R 𝗐𝗂𝗍𝗁 P2
⟹ (snd a ⦂ ◒[Cw] W) = ((wy, wx) ⦂ ◒[Cy] WY ∗ ◒[Cx] WX) @tag 𝒜merge
⟹ a ⦂ A ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst b, fst c), snd c) ⦂ (Y ∗ X) ∗[Cr] R 𝗐𝗂𝗍𝗁 (P1 ∧ P2) ›

By ‹◒›, we can easily merge the two remainders of the transformation two-side. However, using ‹T ∗[C] U›
is not as easy as this.
Nonetheless, ‹T ∗[C] R› is suitable for the one-to-one transformation with remainders.
›

definition φCond_Unital_Ins :: ‹bool ⇒ ('v, 'x) φ ⇒ ('v option, 'x) φ› ("◒[_] _" [20,91] 90)
  ― ‹Conditional Unital Insertion›
  where ‹◒[C] T = (if C then ● T else ○⇩𝗑)›

definition Cond_Unital_Ins_BI :: ‹bool ⇒ 'c BI ⇒ 'c option BI› ("◒⇩B⇩I[_] _" [20,91] 90)
  where ‹◒⇩B⇩I[C] A = (if C then Ψ[Some] A else 1)›


paragraph ‹Rewrites›

lemma Cond_Unital_Ins_BI_φType[no_atp]:
  ‹ ◒⇩B⇩I[C] (x ⦂ T) ≡ x ⦂ ◒[C] T ›
  unfolding φCond_Unital_Ins_def Cond_Unital_Ins_BI_def atomize_eq BI_eq_iff
  by clarsimp

lemma φCond_Unital_Ins_unfold[no_atp]:
  ‹ ◒[C] T = (if C then ● T else ○⇩𝗑) ›
  unfolding φType_def φCond_Unital_Ins_def
  by clarsimp

lemma φCond_Unital_Ins_unfold_simp[simp, φsafe_simp]:
  ‹ ◒[True] T ≡ ● T ›
  ‹ ◒[False] T ≡ ○⇩𝗑 ›
  unfolding φCond_Unital_Ins_unfold
  by simp+

lemma φCond_Unital_Ins_BI_unfold_simp[simp, φsafe_simp]:
  ‹ ◒⇩B⇩I[False] A ≡ 1 ›
  unfolding Cond_Unital_Ins_BI_def
  by simp

lemma φCond_Unital_Ins_expn[simp, φexpns]:
  ‹ p ⊨ (x ⦂ ◒[C] T) ⟷ (if C then (∃v. p = Some v ∧ v ⊨ (x ⦂ T)) else p = None) ›
  unfolding φCond_Unital_Ins_unfold
  by clarsimp

lemma φCond_Unital_BI_Ins_expn[simp, φexpns]:
  ‹ p ⊨ (◒⇩B⇩I[C] A) ⟷ (if C then (∃v. p = Some v ∧ v ⊨ A) else p = None) ›
  unfolding Cond_Unital_Ins_BI_def
  by clarsimp

lemma φCond_Unital_Prod:
  ‹◒[C] T ∗ ◒[C] U ≡ ◒[C] (T ∗ U)›
  unfolding atomize_eq
  by (rule φType_eqI; clarsimp; force)

lemma φCond_Unital_BI_Prod:
  ‹◒⇩B⇩I[C] A * ◒⇩B⇩I[C] B ≡ ◒⇩B⇩I[C] (A * B)›
  unfolding atomize_eq BI_eq_iff
  by (clarsimp; force)

lemma φCond_Unital_trans_rewr:
  ‹ x ⦂ ◒[C] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[C] U 𝗐𝗂𝗍𝗁 C ⟶ P ≡ C ⟶ (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P) ›
  unfolding atomize_eq Transformation_def
  by (cases C; clarsimp; blast)

lemma Cond_φProd_expn_φSome:
  ‹● (T ∗[C] U) ≡ ● T ∗ ◒[C] U›
  unfolding atomize_eq
  by (rule φType_eqI; cases C; clarsimp; force)

lemma Cond_φProd_expn_Cond_φProd:
  ‹◒[C⇩1] (T ∗[C⇩2] U) ≡ ◒[C⇩1] T ∗ ◒[C⇩1 ∧ C⇩2] U›
  unfolding atomize_eq
  by (rule φType_eqI; cases C⇩1; cases C⇩2; clarsimp; force)

lemma LCond_φProd_expn_φSome:
  ‹ ● (T [C]∗ U) ≡ ◒[C] T ∗ ● U ›
  unfolding atomize_eq
  by (rule φType_eqI; cases C; clarsimp; force)


lemma cond_prod_transformation_rewr:
  ‹ x ⦂ T ∗[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U' 𝗐𝗂𝗍𝗁 P ≡ x ⦂ ● T ∗ ◒[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ ● U' 𝗐𝗂𝗍𝗁 P›
  ‹ x' ⦂ T' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C] R 𝗐𝗂𝗍𝗁 P ≡ x' ⦂ ● T' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U ∗ ◒[C] R 𝗐𝗂𝗍𝗁 P›
  unfolding atomize_eq
  by (cases C; clarsimp simp add: φSome_φProd φSome_φNone_freeobj φSome_transformation_strip)+

lemma φCond_Unital_BI_eq_strip:
  ‹ ◒⇩B⇩I[True] A = ◒⇩B⇩I[True] B ≡ A = B ›
  unfolding atomize_eq BI_eq_iff
  by clarsimp blast


paragraph ‹Reasoning Properties›

lemma [φreason 1000]:
  ‹ (⋀x. x ⦂ T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 P x)
⟹ x ⦂ ◒[C] T 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 C ⟶ P x›
  unfolding 𝗋EIF_def Satisfiable_def
  by clarsimp blast


paragraph ‹Transformations›

lemma [φreason %ToA_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P)
⟹ x ⦂ ◒[C] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[C] U 𝗐𝗂𝗍𝗁 C ⟶ P›
  unfolding Premise_def
  by (simp add: φCond_Unital_trans_rewr)

lemma [φreason %ToA_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ x ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁 P)
⟹ x ⦂ ◒[C] T ∗[Cw] ◒[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[C] U ∗[Cr] ◒[C] R 𝗐𝗂𝗍𝗁 C ⟶ P›
  unfolding Premise_def
  by (cases Cw; cases Cr; clarsimp simp add: φCond_Unital_Prod φCond_Unital_trans_rewr)

paragraph ‹Normalization›

subparagraph ‹Source›

lemma [φreason %ToA_red]:
  ‹ x ⦂ ● T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ◒[True] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ◒[False] T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (x ⦂ ● T) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x ⦂ ◒[True] T) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x ⦂ ◒[False] T) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ x ⦂ ● T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ ◒[True] T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_success]:
  ‹ x ⦂ (◒[False] T ∗[True] U) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, unspec) ⦂ (U ∗[False] ⊤⇩φ) ›
  unfolding Action_Tag_def
  by (cases x; simp add: φProd_expn')

subparagraph ‹Target›

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[True] U 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[False] U 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[True] U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[False] U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp
 
lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ● U ∗[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ ◒[True] U ∗[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_success]:
  ‹ May_Assign (snd x) unspec
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (unspec, fst x) ⦂ ◒[False] U ∗[True] T ›
  by (clarsimp simp add: φSome_φNone_freeobj)



subsubsection ‹Conditional Item on Unital Algebra›

abbreviation φCond_Item :: ‹bool ⇒ 'v BI ⇒ 'v::one BI› ("◒⇩𝟭[_] _" [20,91] 90)
  ― ‹Conditional Unital Insertion›
  where ‹◒⇩𝟭[C] A ≡ (if C then A else 1)›

paragraph ‹Rewrites›

lemma φCond_Item_simp[simp, φsafe_simp]:
  ‹ ◒⇩𝟭[True] A ≡ A ›
  ‹ ◒⇩𝟭[False] A ≡ 1 ›
  by simp+

lemma Remains_φCond_Item:
  ‹ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) = A * ◒⇩𝟭[C] R ›
  for A :: ‹'c::sep_magma_1 BI›
  unfolding REMAINS_def
  by (cases C; simp)




subsubsection ‹Bi-Conditioned Product›

definition BiCond_φProd :: ‹ ('v,'x) φ ⇒ bool ⇒ bool ⇒ ('v,'y) φ ⇒ ('v::sep_magma,'x × 'y) φ › ("_ [_]∗[_] _" [71,20,20,71] 70)
    ― ‹φType embedding of conditional remainder›
  where ‹(T [C⇩T]∗[C⇩U] U) ≡ if C⇩T then if C⇩U then T ∗ U else (λx. fst x ⦂ T) else if C⇩U then (λx. snd x ⦂ U) else (λ_. ⊤)›

lemma BiCond_φProd_expn[φexpns, simp]:
  ‹ c ⊨ (x ⦂ T [C⇩T]∗[C⇩U] U) ⟷ (if C⇩T then if C⇩U then c ⊨ (x ⦂ T ∗ U) else c ⊨ (fst x ⦂ T) else if C⇩U then c ⊨ (snd x ⦂ U) else True)›
  unfolding BiCond_φProd_def φType_def
  by (cases C⇩T; cases C⇩U; clarsimp)

lemma BiCond_single_Cond_const_red[simp, φsafe_simp]:
  ‹ (x ⦂ T [False]∗[True] U) = (snd x ⦂ U)›
  ‹ T [True]∗[C] U = T ∗[C] U ›
  ‹ T [False]∗[False] U = ⊤⇩φ ›
  by ((cases x, simp add: BI_eq_iff),
      (rule φType_eqI, clarsimp)+)

lemma BiCond_single_Cond_rewrite:
  ‹ (x ⦂ T ∗[C⇩U ∨ C⇩W] (U [C⇩U]∗[C⇩W] W)) = (prod.rotL x ⦂ (T ∗[C⇩U] U) ∗[C⇩W] W)›
  for T :: ‹('c::sep_semigroup,'a) φ›
  by ((clarsimp simp add: BI_eq_iff; rule; clarsimp),
      metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc',
      metis sep_disj_multD2 sep_disj_multI2 sep_mult_assoc')
      

lemma BiCond_assoc:
  ‹ (x ⦂ (T⇩1 [C⇩1]∗[C⇩2] T⇩2) [C⇩1 ∨ C⇩2]∗[C⇩3] T⇩3) = (prod.rotR x ⦂ T⇩1 [C⇩1]∗[C⇩2 ∨ C⇩3] (T⇩2 [C⇩2]∗[C⇩3] T⇩3))›
  for T⇩1 :: ‹('c::sep_semigroup,'a) φ›
  unfolding BI_eq_iff
  by ((cases x; cases C⇩1; cases C⇩2; cases C⇩3; clarsimp; rule; clarsimp),
      metis sep_disj_multD2 sep_disj_multI2 sep_mult_assoc',
      metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc')
      

lemma BiCond_assoc':
  ‹ (x ⦂ T⇩0 ∗[C⇩1 ∨ C⇩2 ∨ C⇩3] ((T⇩1 [C⇩1]∗[C⇩2] T⇩2) [C⇩1 ∨ C⇩2]∗[C⇩3] T⇩3)) = (apsnd prod.rotR x ⦂ T⇩0 ∗[C⇩1 ∨ C⇩2 ∨ C⇩3] (T⇩1 [C⇩1]∗[C⇩2 ∨ C⇩3] (T⇩2 [C⇩2]∗[C⇩3] T⇩3))) ›
  for T⇩0 :: ‹('c::sep_semigroup,'a) φ›
  unfolding BI_eq_iff
  by ((cases x; cases C⇩1; cases C⇩2; cases C⇩3; clarsimp; rule; clarsimp),
      metis sep_disj_multD2 sep_disj_multI2 sep_mult_assoc',
      metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc')

lemma BiCond_expn_φSome:
  ‹ C⇩1 ∨ C⇩2
⟹ ● (T [C⇩1]∗[C⇩2] U) ≡ ◒[C⇩1] T ∗ ◒[C⇩2] U›
  unfolding atomize_eq
  by ((rule φType_eqI; cases C⇩1; cases C⇩2; clarsimp; rule; clarsimp),
      metis sep_disj_option(1) times_option(1),
      blast)

lemma BiCond_expn_BiCond:
  ‹ C ⟶ C⇩1 ∨ C⇩2
⟹ ◒[C] (T [C⇩1]∗[C⇩2] U) ≡ ◒[C ∧ C⇩1] T ∗ ◒[C ∧ C⇩2] U ›
  unfolding atomize_eq
  by ((rule φType_eqI; cases C; cases C⇩1; cases C⇩2; clarsimp; rule; clarsimp),
      metis sep_disj_option(1) times_option(1),
      blast)


paragraph ‹Syntax›

text ‹
  ‹U⇩0 [C⇩0]∗[C⇩1,C⇩2,…] (U⇩1,U⇩2,…) := U⇩0 [C⇩0]∗[C⇩1 ∨ C⇩2 ∨ …] (U⇩1 [C⇩1]∗[C⇩2 ∨ C⇩3 ∨ …] (U⇩2 [C⇩2]∗[C⇩3 ∨ …] …)) ›
  is self-similar, where a pattern of ‹U⇩0 [C⇩0]∗[C⇩1,…,C⇩n] (U⇩1,…,U⇩n)› matches any structure
  ‹U⇩0 [C⇩0]∗[C⇩1,…,C⇩m] (U⇩1,…,U⇩m)› for ‹m ≥ n›.

  ‹T ∗[C⇩0,…,C⇩n] (U⇩0,…,U⇩n) := T ∗[C⇩0 ∨ … ∨ C⇩0] (U⇩0 [C⇩0]∗[C⇩1,…,C⇩n] (U⇩1,…,U⇩n))›
›

no_notation Cond_φProd ("_ ∗[_]/ _" [71,20,70] 70)
        and BiCond_φProd ("_ [_]∗[_] _" [71,20,20,71] 70)
        and LeftCond_φProd ("_ [_]∗ _" [69,20,70] 68)

syntax "_Cond_φProds" :: ‹logic ⇒ tuple_args ⇒ logic ⇒ logic› ("_ ∗[_]/ _" [71,20,71] 70)
       "_BiCond_φProds" :: ‹logic ⇒ logic ⇒ tuple_args ⇒ logic ⇒ logic› ("_ [_]∗[_]/ _" [71,20,20,71] 70)
       "_LCond_φProds" :: ‹logic ⇒ tuple_args ⇒ logic ⇒ logic› ("_ [_]∗/ _" [69,20,70] 68)

parse_translation ‹
let fun parse is_left (A, Ac, Cs, B) =
      let fun strip_tuple (Const(\<^syntax_const>‹_tuple_args›, _) $ C $ Cs) = C :: strip_tuple Cs
            | strip_tuple (Const(\<^syntax_const>‹_tuple_arg›, _) $ C) = [C]
          fun strip_pair (Const(\<^const_syntax>‹Pair›, _) $ B $ Bs) = B :: strip_pair Bs
            | strip_pair X = [X]
          val Bs = strip_pair B   |> is_left ? rev
          val Cs = strip_tuple Cs |> is_left ? rev
          val _ = if length Bs = length Cs then ()
                  else error "Bad Syntax: Unbalanced length of ‹_ ∗[_,_,this] (_,_,and,this)›"
          fun mkL A _ [] [] = A
            | mkL A Ac [B] [C] = Const(\<^const_name>‹BiCond_φProd›, dummyT) $ B $ C $ Ac $ A
            | mkL A Ac (B::Bs) (C::Cs) =
                Const(\<^const_name>‹BiCond_φProd›, dummyT)
                  $ (mkL B C Bs Cs)
                  $ foldr1 (fn (a,b) => HOLogic.mk_disj (b,a)) (C::Cs)
                  $ Ac
                  $ A
          fun mk A _ [] [] = A
            | mk A Ac [B] [C] = Const(\<^const_name>‹BiCond_φProd›, dummyT) $ A $ Ac $ C $ B
            | mk A Ac (B::Bs) (C::Cs) =
                Const(\<^const_name>‹BiCond_φProd›, dummyT) $ A
                  $ Ac
                  $ foldr1 HOLogic.mk_disj (C::Cs)
                  $ (mk B C Bs Cs)
       in if is_left
       then Const(\<^const_name>‹LeftCond_φProd›, dummyT)
                    $ mkL (hd Bs) (hd Cs) (tl Bs) (tl Cs)
                    $ foldl1 HOLogic.mk_disj (rev Cs)
                    $ A
       else case Ac
         of SOME Ac => mk A Ac Bs Cs
          | _ => Const(\<^const_name>‹Cond_φProd›, dummyT) $ A
                    $ foldr1 HOLogic.mk_disj Cs
                    $ mk (hd Bs) (hd Cs) (tl Bs) (tl Cs)
      end
 in [(\<^syntax_const>‹_Cond_φProds›, fn _ => fn [A,Cs,B] => parse false (A,NONE,Cs,B)),
     (\<^syntax_const>‹_BiCond_φProds›, fn _ => fn [A,Ac,Cs,B] => parse false (A,SOME Ac,Cs,B)),
     (\<^syntax_const>‹_LCond_φProds›, fn _ => fn [A,Cs,B] => parse true (B,NONE,Cs,A))]
end›

(*TEST:
term ‹U ∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
term ‹U [C]∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)› 
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U ∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U›
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U [C]∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
*)

print_translation ‹
  let fun parseL (Const(\<^const_syntax>‹BiCond_φProd›, _)
                  $ (Us' as Const(\<^const_syntax>‹BiCond_φProd›, _) $ _ $ _ $ _ $ _)
                  $ (CUs' as Const(\<^const_syntax>‹HOL.disj›, _) $ _ $ _)
                  $ CT $ T) =
            let fun strip_disj (Const(\<^const_syntax>‹HOL.disj›, _) $ Cs $ C) = C :: strip_disj Cs
                  | strip_disj C = [C]
                val (Us, CUs) = parseL Us'
                val myCUs = strip_disj CUs'
                val _ = if eq_list Term.aconv_untyped (CUs, myCUs) then () else raise Match
             in (T::Us, CT::CUs)
            end
        | parseL (Const(\<^const_syntax>‹BiCond_φProd›, _) $ U $ CU $ CT $ T) = ([T,U], [CT,CU])

      fun parse (Const(\<^const_syntax>‹BiCond_φProd›, _) $ T $ CT
                  $ (CUs' as Const(\<^const_syntax>‹HOL.disj›, _) $ _ $ _)
                  $ (Us' as Const(\<^const_syntax>‹BiCond_φProd›, _) $ _ $ _ $ _ $ _)) =
            let fun strip_disj (Const(\<^const_syntax>‹HOL.disj›, _) $ C $ Cs) = C :: strip_disj Cs
                  | strip_disj C = [C]
                val (Us, CUs) = parse Us'
                val myCUs = strip_disj CUs'
                val _ = if eq_list Term.aconv_untyped (CUs, myCUs) then () else raise Match
             in (T::Us, CT::CUs)
            end
        | parse (Const(\<^const_syntax>‹BiCond_φProd›, _) $ T $ CT $ CU $ U) = ([T,U], [CT,CU])

      fun mk is_left (T::Us) (CT::CUs) =
        let val head = (if pointer_eq (CT, Term.dummy_prop)
                        then if is_left then Const(\<^syntax_const>‹_LCond_φProds›, dummyT)
                                        else Const(\<^syntax_const>‹_Cond_φProds›, dummyT) $ T
                        else Const(\<^syntax_const>‹_BiCond_φProds›, dummyT) $ T $ CT)
            val CUs = case CUs
                        of [_] => hd CUs
                         | _ => foldl1 (fn (a,b) => Const(\<^syntax_const>‹_tuple_args›, dummyT) $ a $ b)
                                       (if is_left then rev CUs else CUs)
            val Us = case (if is_left then rev Us else Us)
                       of [_] => hd Us
                        | U::Uss =>
                            Const(\<^syntax_const>‹_tuple›, dummyT) $ U
                              $ foldl1 (fn (a,b) => Const(\<^syntax_const>‹_tuple_args›, dummyT) $ a $ b) Uss
         in if is_left then head $ Us $ CUs $ T
            else head $ CUs $ Us
        end

      fun print is_left (T',CT',CU',U') =
        let val (Ts,Cs) = if is_left
                          then parseL (Const(\<^const_syntax>‹BiCond_φProd›, dummyT) $ T' $ CT' $ CU' $ U')
                          else parse  (Const(\<^const_syntax>‹BiCond_φProd›, dummyT) $ T' $ CT' $ CU' $ U')
         in mk is_left Ts Cs
        end
   in [(\<^const_syntax>‹BiCond_φProd›, fn _ => fn [T,CT,CU,U] => print false (T,CT,CU,U)),
       (\<^const_syntax>‹Cond_φProd›, fn _ => fn [T,CU,U] => print false (T,Term.dummy_prop,CU,U)),
       (\<^const_syntax>‹LeftCond_φProd›, fn _ => fn [T,CU,U] => print true (T,CU,Term.dummy_prop,U))]
  end
›

(*TEST:
term ‹U ∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
term ‹U [C]∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)› 
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U ∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U [C]∗[C⇩1, C⇩2, C⇩3] (R⇩1, R⇩2, R⇩3)›
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U›
 
term ‹(L⇩4,L⇩3,L⇩2,L⇩1) [D⇩4,D⇩3,D⇩2,D⇩1]∗ U›*)

subsubsection ‹Merging Conditioned φ-Types \& Assertions›

consts 𝒜merge :: action

declare [[φreason_default_pattern
      ‹(_ ⦂ ◒[_] _) = ((_,_) ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _) @tag 𝒜merge› ⇒  (*objects: LHS determines RHS*)
      ‹(_ ⦂ ◒[_] _) = (_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _) @tag 𝒜merge›   (100) (*types:   LHS determines RHS*)
  and ‹(_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _) = (_ ⦂ ◒[_] _) @tag 𝒜merge› ⇒      (*objects: RHS determines LHS*)
      ‹(_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _) = (_ ⦂ ◒[_] _) @tag 𝒜merge›   (100) (*types:   LHS determines RHS*)

  and ‹(_ ⦂ ◒[_] _) = ((_,_,_) ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _ ∗ ◒[?Cc] _) @tag 𝒜merge› ⇒
      ‹(_ ⦂ ◒[_] _) = (_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _ ∗ ◒[?Cc] _) @tag 𝒜merge›   (100)
  and ‹(_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _ ∗ ◒[?Cc] _) = (_ ⦂ ◒[_] _) @tag 𝒜merge› ⇒
      ‹(_ ⦂ ◒[?Ca] _ ∗ ◒[?Cb] _ ∗ ◒[?Cc] _) = (_ ⦂ ◒[_] _) @tag 𝒜merge›   (100)

  and ‹◒[_] _ = ◒[?C⇩A] _ ∗ ◒[?C⇩B] _ @tag 𝒜merge› ⇒
      ‹◒[_] _ = ◒[?C⇩A] _ ∗ ◒[?C⇩B] _ @tag 𝒜merge›    (100)
  and ‹◒[_] _ = ◒[?C⇩A] _ ∗ ◒[?C⇩B] _ ∗ ◒[?C⇩C] _ @tag 𝒜merge› ⇒
      ‹◒[_] _ = ◒[?C⇩A] _ ∗ ◒[?C⇩B] _ ∗ ◒[?C⇩C] _ @tag 𝒜merge›    (100)

  and ‹◒⇩B⇩I[_] _ = ◒⇩B⇩I[?C⇩A] _ * ◒⇩B⇩I[?C⇩B] _ @tag 𝒜merge› ⇒
      ‹◒⇩B⇩I[_] _ = ◒⇩B⇩I[?C⇩A] _ * ◒⇩B⇩I[?C⇩B] _ @tag 𝒜merge›    (100)

(*and ‹_ = (if ?flag then _ else _) @tag 𝒜merge › ⇒
      ‹_ = (if ?flag then _ else _) @tag 𝒜merge ›   (100)*)
(*  and ‹?flag ⟶ _ @tag 𝒜merge› ⇒
      ‹?flag ⟶ _ @tag 𝒜merge›   (100)*)
  and ‹?X @tag 𝒜merge› ⇒
      ‹ERROR TEXT(‹Malformed 𝒜merge rule› (?X @tag 𝒜merge))› (0)
]]

φreasoner_group 𝒜merge = (%cutting, [%cutting, %cutting+20]) for ‹(_ ⦂ ◒[_] _) = _›
  ‹Rules merging multiple conditioned φtypes into one conditioned φtype,
   always using the abstract object(s) given in the left hand side to assign the abstract object(s)
   in the right.›

text ‹Information is always given from left to right below.
      They accept arguments from LHS and assign the result to RHS›

paragraph ‹Simplification Protects›

definition [simplification_protect]:
  ‹𝒜merge_SP P ≡ P @tag 𝒜merge›

lemma [cong]:
  ‹𝒜merge_SP P ≡ 𝒜merge_SP P› .

paragraph ‹Implementation›

lemma [φreason %𝒜merge+20 for ‹(fst (_,_) ⦂ _) = _ @tag 𝒜merge›]:
  ‹ (x ⦂ T) = Y @tag 𝒜merge
⟹ (fst (x,y) ⦂ T) = Y @tag 𝒜merge ›
  by simp

lemma [φreason %𝒜merge+20 for ‹(snd (_,_) ⦂ _) = _ @tag 𝒜merge›]:
  ‹ (y ⦂ U) = Y @tag 𝒜merge
⟹ (snd (x,y) ⦂ U) = Y @tag 𝒜merge ›
  by simp_all

lemma [φreason %𝒜merge+20 for ‹((_, snd _) ⦂ _) = _ @tag 𝒜merge›]:
  ‹ ((x, z) ⦂ U) = Y @tag 𝒜merge
⟹ ((x, snd (y,z)) ⦂ U) = Y @tag 𝒜merge ›
  by simp_all

lemma [φreason %𝒜merge+20 for ‹((_, fst _) ⦂ _) = _ @tag 𝒜merge›]:
  ‹ ((x, y) ⦂ U) = Y @tag 𝒜merge
⟹ ((x, fst (y,z)) ⦂ U) = Y @tag 𝒜merge ›
  by simp_all

lemma [φreason %𝒜merge]: ― ‹contracts two sides respectively›
  ‹(x ⦂ ◒[True] (A ∗ B)) = ((fst x, snd x) ⦂ ◒[True] A ∗ ◒[True] B) @tag 𝒜merge›
  ‹(a ⦂ ◒[True] A) = ((a, unspec) ⦂ ◒[True] A ∗ ◒[False] B) @tag 𝒜merge›
  ‹(b ⦂ ◒[True] B) = ((unspec, b) ⦂ ◒[False] A ∗ ◒[True] B) @tag 𝒜merge›
  ‹(any ⦂ ◒[False] ⊤⇩φ) = ((unspec, unspec) ⦂ ◒[False] A ∗ ◒[False] B) @tag 𝒜merge›
  unfolding Action_Tag_def BI_eq_iff
  by (clarsimp; force)+

lemma [φreason %𝒜merge]:
  ‹ (x ⦂ ◒[True] A ∗ ◒[True] B) = (x ⦂ ◒[True] (A ∗ B)) @tag 𝒜merge ›
  ‹ (x ⦂ ◒[True] A ∗ ◒[False] B) = (fst x ⦂ ◒[True] A) @tag 𝒜merge ›
  ‹ (x ⦂ ◒[False] A ∗ ◒[True] B) = (snd x ⦂ ◒[True] B) @tag 𝒜merge ›
  ‹ (x ⦂ ◒[False] A ∗ ◒[False] B) = (unspec ⦂ ◒[False] ⊤⇩φ) @tag 𝒜merge ›
  unfolding Action_Tag_def BI_eq_iff
  by (clarsimp; force)+

lemma [φreason %𝒜merge+10]:
  ‹ ((x,y) ⦂ ◒[True] A ∗ ◒[False] B) = (x ⦂ ◒[True] A) @tag 𝒜merge ›
  ‹ ((x,y) ⦂ ◒[False] A ∗ ◒[True] B) = (y ⦂ ◒[True] B) @tag 𝒜merge ›
  unfolding Action_Tag_def BI_eq_iff
  by (clarsimp; force)+

lemma [φreason %𝒜merge]:
  ‹(x ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[True]  R) = (x ⦂ ◒[True] (T ∗ U ∗ R)) @tag 𝒜merge›
  ‹(x ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[False] R) = ((fst x, fst (snd x)) ⦂ ◒[True] (T ∗ U)) @tag 𝒜merge›
  ‹(x ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[True] R) = ((fst x, snd (snd x)) ⦂ ◒[True] (T ∗ R)) @tag 𝒜merge›
  ‹(x ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[False] R) = (fst x ⦂ ◒[True] T) @tag 𝒜merge›

  ‹(x ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[True] R) = ((fst (snd x), snd (snd x)) ⦂ ◒[True] (U ∗ R)) @tag 𝒜merge›
  ‹(x ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[False] R) = (fst (snd x) ⦂ ◒[True] U) @tag 𝒜merge›
  ‹(x ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[True] R) = (snd (snd x) ⦂ ◒[True] R) @tag 𝒜merge›
  ‹(x ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[False] R) = (unspec ⦂ ◒[False] ⊤⇩φ) @tag 𝒜merge›
  unfolding Action_Tag_def
  by (cases x, clarsimp simp add: φSome_φNone_freeobj φProd_expn' φProd_expn'' φSome_φProd[symmetric])+

lemma [φreason %𝒜merge+5]:
  ‹((x,y) ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[False] R) = ((x, fst y) ⦂ ◒[True] (T ∗ U)) @tag 𝒜merge›
  ‹((x,y) ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[True] R) = ((x, snd y) ⦂ ◒[True] (T ∗ R)) @tag 𝒜merge›
  ‹((x,y) ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[False] R) = (x ⦂ ◒[True] T) @tag 𝒜merge›

  ‹((x,y) ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[True] R) = (y ⦂ ◒[True] (U ∗ R)) @tag 𝒜merge›
  ‹((x,y) ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[False] R) = (fst y ⦂ ◒[True] U) @tag 𝒜merge›
  ‹((x,y) ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[True] R) = (snd y ⦂ ◒[True] R) @tag 𝒜merge›
  unfolding Action_Tag_def
  by (cases y, clarsimp simp add: φSome_φNone_freeobj φProd_expn' φProd_expn'' φSome_φProd[symmetric])+

lemma [φreason %𝒜merge+10]:
  ‹((x,y,z) ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[False] R) = ((x,y) ⦂ ◒[True] (T ∗ U)) @tag 𝒜merge›
  ‹((x,y,z) ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[True] R) = ((x,z) ⦂ ◒[True] (T ∗ R)) @tag 𝒜merge›
  ‹((x,y,z) ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[False] R) = (y ⦂ ◒[True] U) @tag 𝒜merge›
  ‹((x,y,z) ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[True] R) = (z ⦂ ◒[True] R) @tag 𝒜merge›
  unfolding Action_Tag_def
  by(clarsimp simp add: φSome_φNone_freeobj φProd_expn' φProd_expn'' φSome_φProd[symmetric])+

lemma [φreason %𝒜merge]:
  ‹(x1 ⦂ ◒[True] (T ∗ U ∗ R)) = ((fst x1, fst (snd x1), snd (snd x1)) ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[True]  R) @tag 𝒜merge›
  ‹(x2 ⦂ ◒[True] (T ∗ U)) = ((fst x2, snd x2, unspec) ⦂ ◒[True] T ∗ ◒[True] U ∗ ◒[False] R) @tag 𝒜merge›
  ‹(x3 ⦂ ◒[True] (T ∗ R)) = ((fst x3, unspec, snd x3) ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[True] R) @tag 𝒜merge›
  ‹(x4 ⦂ ◒[True] T) = ((x4, unspec, unspec) ⦂ ◒[True] T ∗ ◒[False] U ∗ ◒[False] R) @tag 𝒜merge›

  ‹(x5 ⦂ ◒[True] (U ∗ R)) = ((unspec, fst x5, snd x5) ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[True] R) @tag 𝒜merge›
  ‹(x6 ⦂ ◒[True] U) = ((unspec, x6, unspec) ⦂ ◒[False] T ∗ ◒[True] U ∗ ◒[False] R) @tag 𝒜merge›
  ‹(x7 ⦂ ◒[True] R) = ((unspec, unspec, x7) ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[True] R) @tag 𝒜merge›
  ‹(unspec ⦂ ◒[False] ⊤⇩φ) = ((unspec, unspec, unspec) ⦂ ◒[False] T ∗ ◒[False] U ∗ ◒[False] R) @tag 𝒜merge›
  unfolding Action_Tag_def
  by (clarsimp simp add: φSome_φProd[symmetric] φProd_expn' φProd_expn'' φSome_φNone_freeobj)+


paragraph ‹Merging Conditioned BI Assertion›

lemma [φreason %𝒜merge]:
  ‹ ◒⇩B⇩I[True] (A * B) = (◒⇩B⇩I[True] A) * (◒⇩B⇩I[True] B) @tag 𝒜merge ›
  ‹ ◒⇩B⇩I[True] A = (◒⇩B⇩I[True] A) * (◒⇩B⇩I[False] B) @tag 𝒜merge ›
  ‹ ◒⇩B⇩I[True] B = (◒⇩B⇩I[False] A) * (◒⇩B⇩I[True] B) @tag 𝒜merge ›
  ‹ ◒⇩B⇩I[False] ⊤ = (◒⇩B⇩I[False] A) * (◒⇩B⇩I[False] B) @tag 𝒜merge ›
  unfolding Action_Tag_def BI_eq_iff
  by (clarsimp; force)+

lemma [φreason %𝒜merge]:
  ‹ ◒[True] (A ∗ B) = ◒[True] A ∗ ◒[True] B @tag 𝒜merge ›
  ‹ ◒[True] (A ∗[False] ⊤⇩φ) = ◒[True] A ∗ ◒[False] B @tag 𝒜merge ›
  ‹ ◒[True] (⊤⇩φ [False]∗ B) = ◒[False] A ∗ ◒[True] B @tag 𝒜merge ›
  ‹ ◒[False] ⊤⇩φ = ◒[False] A ∗ ◒[False] B @tag 𝒜merge ›
  unfolding Action_Tag_def
  by (rule φType_eqI_BI; clarsimp simp add: BI_eq_iff; force)+

lemma [φreason %𝒜merge]:
  ‹ ◒[True] (A ∗ B ∗ C) = ◒[True] A ∗ ◒[True] B ∗ ◒[True] C @tag 𝒜merge ›
  ‹ ◒[True] (A ∗[False] ⊤⇩φ) = ◒[True] A ∗ ◒[False] B ∗ ◒[False] C @tag 𝒜merge ›
  ‹ ◒[True] (A ∗ B ∗[False] ⊤⇩φ) = ◒[True] A ∗ ◒[True] B ∗ ◒[False] C @tag 𝒜merge ›
  ‹ ◒[True] (A ∗ (⊤⇩φ [False]∗ C)) = ◒[True] A ∗ ◒[False] B ∗ ◒[True] C @tag 𝒜merge ›
  ‹ ◒[True] (⊤⇩φ [False]∗ B ∗ C) = ◒[False] A ∗ ◒[True] B ∗ ◒[True] C @tag 𝒜merge ›
  ‹ ◒[True] (⊤⇩φ [False]∗ (⊤⇩φ [False]∗ C)) = ◒[False] A ∗ ◒[False] B ∗ ◒[True] C @tag 𝒜merge ›
  ‹ ◒[True] (⊤⇩φ [False]∗ (B ∗[False] ⊤⇩φ)) = ◒[False] A ∗ ◒[True] B ∗ ◒[False] C @tag 𝒜merge ›
  ‹ ◒[False] ⊤⇩φ = ◒[False] A ∗ ◒[False] B ∗ ◒[False] C @tag 𝒜merge ›
  unfolding Action_Tag_def
  by (rule φType_eqI_BI; clarsimp simp add: BI_eq_iff; force)+

paragraph ‹Nested Merging›

lemma [φreason %𝒜merge for ‹◒[_] _ = ◒[_] _ ∗ ◒[_ ∨ _] (_ [_]∗[_] _) @tag 𝒜merge›]:
  ‹ ◒[C⇩Y] Y = ◒[C⇩B] B ∗ ◒[C⇩C] C @tag 𝒜merge
⟹ ◒[C⇩X] X = ◒[C⇩A] A ∗ ◒[C⇩Y] Y @tag 𝒜merge
⟹ ◒[C⇩X] X = ◒[C⇩A] A ∗ ◒[C⇩B ∨ C⇩C] (B [C⇩B]∗[C⇩C] C) @tag 𝒜merge ›
  unfolding Action_Tag_def
  by (clarsimp simp: BiCond_expn_BiCond; cases C⇩A; cases C⇩B; cases C⇩C; simp)

subsubsection ‹Separation Extraction of ‹φ›Prod›

text ‹Using the technical auxiliaries, we can give the separation extraction for ‹φProd››

lemma Structural_Extract_φProd_right_i[φreason %ToA_cut]:
  ‹ (fst a, wy) ⦂ A ∗[Cy] WY 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b ⦂ Y ∗[Cb] B 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ if Cb then ((snd b, wx) ⦂ B ∗[Cx] WX 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 c ⦂ X ∗[Cr] R 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫')
          else (Cx, Cr, WX, c, P2) = (True, False, X, (wx, unspec), True)
⟹ (snd a ⦂ ◒[Cw] W) = ((wy, wx) ⦂ ◒[Cy] WY ∗ ◒[Cx] WX) @tag 𝒜merge
⟹ a ⦂ A ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst b, fst c), snd c) ⦂ (Y ∗ X) ∗[Cr] R 𝗐𝗂𝗍𝗁 (P1 ∧ P2) @tag 𝒯𝒫'›
  for A :: ‹('a::sep_semigroup,'b) φ›
  unfolding Action_Tag_def Try_def
  apply (cases Cb; simp add: cond_prod_transformation_rewr;
         clarsimp simp add: φProd_expn'' φProd_expn' φSome_φProd[symmetric] Cond_φProd_expn_φSome)
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=‹wx ⦂ ◒[Cx] WX›]
               prems(2)[THEN transformation_left_frame, where R=‹fst b ⦂ ● Y›],
        simp add: mult.assoc transformation_trans)
  by (metis (no_types, lifting) mult.assoc transformation_right_frame)

(* TODO!
lemma [φreason 1201]:
  ‹ Try S1 ((fst a, wy) ⦂ ● A ∗ ◒[Cy] WY 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 b ⦂ ● Y ∗ ◒[Cb] B 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'1 ⦂ ● Y' ∗ ◒[Cb] B') (x'1 ⦂ ● A' ∗ ◒[Cy] WY') ∧ P1 @tag 𝒜SEi )
⟹ Try S2 ((snd b, wx) ⦂ ◒[Cb] B ∗ ◒[Cx] WX 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 c ⦂ ● X ∗ ◒[Cr] R 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'2 ⦂ ● X' ∗ ◒[Cr] R') (x'2 ⦂ ◒[Cb] B' ∗ ◒[Cx] WX') ∧ P2 @tag 𝒜SEi )
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 S1 ∨ S2
⟹ (snd a ⦂ ◒[Cw] W) = ((wy, wx) ⦂ ◒[Cy] WY ∗ ◒[Cx] WX) @tag 𝒜merge
⟹ a ⦂ ● A ∗ ◒[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst b, fst c), snd c) ⦂ ● (Y ∗ X) ∗ ◒[Cr] R 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'3 ⦂ ● (Y' ∗ X') ∗ ◒[Cr] R') (x'3 ⦂ ● A' ∗ ◒[Cw] W') ∧ P1 ∧ P2 @tag 𝒜SEi ›
  for A :: ‹('a::sep_semigroup,'b) φ› and A' :: ‹('a'::sep_semigroup,'b') φ›
  unfolding Auto_Transform_Hint_def HOL.simp_thms(22)
  using Structural_Extract_φProd_right_i .*)

lemma Structural_Extract_φProd_left_i [φreason %ToA_cut]:
  ‹ (fst (fst x), fst wr) ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr ⦂ Y ∗[Cra] Rt 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ if Cw then ((snd (fst x), snd x) ⦂ U ∗[Cw2] W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wr ⦂ W ∗[Crb] Ru 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫')
          else (Cw2, Crb, Ru, wr, P2) = (False, True, U, (unspec, snd (fst x)), True)
⟹ ((snd yr, snd wr) ⦂ ◒[Cra] Rt ∗ ◒[Crb] Ru) = (r ⦂ ◒[Cr] R) @tag 𝒜merge
⟹ x ⦂ (T ∗ U) ∗[Cw2] W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst yr, r) ⦂ Y ∗[Cr] R 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫' ›
  for T :: ‹('a::sep_semigroup,'b) φ›
  unfolding Action_Tag_def Try_def
  apply (cases Cw; simp add: cond_prod_transformation_rewr;
         simp add: φProd_expn'' φProd_expn' φSome_φProd[symmetric] Cond_φProd_expn_φSome)
  subgoal premises prems
    by (insert prems(1)[THEN transformation_right_frame, where R=‹snd wr ⦂ ◒[Crb] Ru›]
               prems(2)[THEN transformation_left_frame, where R=‹fst (fst x) ⦂ ● T›],
        simp add: mult.assoc[symmetric] prems(3)[symmetric],
        smt (z3) Transformation_def)
  by (metis (no_types, lifting) mult.assoc transformation_right_frame)


(* TODO
lemma [φreason 1201]:
  ‹ Try S1 ((fst (fst x), fst wr) ⦂ ● T ∗ ◒[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr ⦂ ● Y ∗ ◒[Cra] Rt 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'1 ⦂ ● Y' ∗ ◒[Cra] Rt') (x'1 ⦂ ● T' ∗ ◒[Cw] W') ∧ P1 @tag 𝒜SEi )
⟹ Try S2 ((snd (fst x), snd x) ⦂ ● U ∗ ◒[Cw2] W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 wr ⦂ ◒[Cw] W ∗ ◒[Crb] Ru 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'2 ⦂ ◒[Cw] W' ∗ ◒[Crb] Ru') (x'2 ⦂ ● U' ∗ ◒[Cw2] W2') ∧ P2 @tag 𝒜SEi )
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 S1 ∨ S2
⟹ ((snd yr, snd wr) ⦂ ◒[Cra] Rt ∗ ◒[Crb] Ru) = (r ⦂ ◒[Cr] R) @tag 𝒜merge
⟹ x ⦂ ● (T ∗ U) ∗ ◒[Cw2] W2 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (fst yr, r) ⦂ ● Y ∗ ◒[Cr] R 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'1 ⦂ ● Y' ∗ ◒[Cr] R') (x'3 ⦂ ● (T' ∗ U') ∗ ◒[Cw2] W2') ∧ P1 ∧ P2 @tag 𝒜SEi ›
  for T :: ‹('a::sep_semigroup,'b) φ› and T' :: ‹('a'::sep_semigroup,'b') φ›
  unfolding Auto_Transform_Hint_def HOL.simp_thms(22)
  using Structural_Extract_φProd_left_i .
*)


section ‹Basic φ-Type Properties›

text ‹The two properties are essential for reasoning the general transformation including separation extraction.›


subsection ‹Identity Element I\&E›

definition Identity_Element⇩I :: ‹'a::one BI ⇒ bool ⇒ bool› where ‹Identity_Element⇩I S P ⟷ (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P)›
definition Identity_Element⇩E :: ‹'a::one BI ⇒ bool› where ‹Identity_Element⇩E S ⟷ (1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S)›

definition Identity_Elements⇩I :: ‹('c::one,'a) φ ⇒ ('a ⇒ bool) ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Identity_Elements⇩I T D P ⟷ (∀x. D x ⟶ Identity_Element⇩I (x ⦂ T) (P x))›

definition Identity_Elements⇩E :: ‹('c::one,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Identity_Elements⇩E T D ⟷ (∀x. D x ⟶ Identity_Element⇩E (x ⦂ T))›

definition Identity_Elements :: ‹('c::one,'a) φ ⇒ ('a ⇒ bool) ⇒ bool›
  where ‹Identity_Elements T D ⟷ Identity_Elements⇩I T D (λ_. True) ∧ Identity_Elements⇩E T D›

lemma Identity_Elements_alt_def:
  ‹Identity_Elements T D ⟷ (∀x. D x ⟶ (x ⦂ T) = 1)›
  unfolding Identity_Elements_def Identity_Elements⇩I_def Identity_Element⇩I_def
            Identity_Elements⇩E_def Identity_Element⇩E_def BI_eq_ToA
  by (rule; clarsimp)
  

definition Hint_Identity_Element :: ‹('c::one,'a) φ ⇒ 'a ⇒ bool›
  where ‹Hint_Identity_Element T one ≡ True›
  ― ‹a pure syntactical hint›

declare [[ φreason_default_pattern
      ‹Identity_Element⇩I ?S _› ⇒ ‹Identity_Element⇩I ?S _› (100)
  and ‹Identity_Element⇩I (_ ⦂ ?T) _› ⇒ ‹Identity_Element⇩I (_ ⦂ ?T) _› (110)
  and ‹Identity_Element⇩E ?S› ⇒ ‹Identity_Element⇩E ?S› (100)
  and ‹Identity_Element⇩E (_ ⦂ ?T)› ⇒ ‹Identity_Element⇩E (_ ⦂ ?T)› (110)

  and ‹Identity_Elements⇩I ?T _ _› ⇒ ‹Identity_Elements⇩I ?T _ _› (100)
  and ‹Identity_Elements⇩E ?T _› ⇒ ‹Identity_Elements⇩E ?T _› (100)

  and ‹Hint_Identity_Element ?T _› ⇒ ‹Hint_Identity_Element ?T _› (100)
  and ‹Identity_Elements ?T _› ⇒ ‹Identity_Elements ?T _› (100)
]]

φreasoner_group identity_element = (100,[1,3000]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
    ‹Reasoning rules deducing if the given assertion can transform to or be transformed from the
     assertion of identity element.›
 and identity_element_fallback = (1,[1,1]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
     in identity_element > fail
    ‹Fallbacks of reasoning Identity_Element.›
 and identity_element_φ = (10, [10, 11]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
    ‹Turning to ‹Identity_Elements⇩I› and ‹Identity_Elements⇩E››
 and derived_identity_element = (50, [50,55]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
     in identity_element > identity_element_φ
    ‹Automatically derived Identity_Element rules›
 and identity_element_top = (2900, [2900,2999]) in identity_element ‹top›
 and identity_element_cut = (1000, [1000,1029]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
     in identity_element > derived_identity_element < identity_element_top
    ‹Cutting rules for Identity_Element›
 and identity_element_OPEN_MAKE = (1100, [1100,1100]) in identity_element
     and > identity_element_cut < identity_element_top ‹›
 and identity_element_red = (2500, [2500, 2530]) for (‹Identity_Element⇩I _ _›, ‹Identity_Element⇩E _›)
     in identity_element > identity_element_cut
    ‹Literal Reduction›
 and identity_element_ToA = (50, [50,51]) for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› in ToA
    ‹Entry points from ToA to Identity_Element›

 and identity_element_hint = (1000, [10, 2000]) for ‹Hint_Identity_Element T ie›
    ‹syntactical hints suggesting an identity element of the given φ-type›

subsubsection ‹Extracting Pure Facts›

paragraph ‹Identity_Element›

lemma [φreason %extract_pure]:
  ‹ 𝗋ESC Q (Satisfiable S)
⟹ 𝗋EIF (Identity_Element⇩I S P) (Q ⟶ P) ›
  unfolding Identity_Element⇩I_def 𝗋ESC_def 𝗋EIF_def Transformation_def Satisfiable_def
  by blast

lemma [φreason %extract_pure]:
  ‹ 𝗋EIF (Satisfiable S) P
⟹ 𝗋EIF (Identity_Element⇩E S) P ›
  unfolding Identity_Element⇩E_def 𝗋ESC_def 𝗋EIF_def Transformation_def Satisfiable_def
  by blast

lemma Identity_Element⇩I_𝒜EIF_sat:
  ‹ 𝗋EIF (Identity_Element⇩I S P) (∀v. v ⊨ S ⟶ v = 1 ∧ P) ›
  unfolding Identity_Element⇩I_def 𝗋EIF_def Transformation_def
  by blast

lemma Identity_Element⇩I_𝒜ESC_sat:
  ‹ 𝗋ESC (∀v. v ⊨ S ⟶ v = 1 ∧ P) (Identity_Element⇩I S P) ›
  unfolding Identity_Element⇩I_def 𝗋ESC_def Transformation_def
  by blast

lemma Identity_Element⇩E_𝒜EIF_sat:
  ‹ 𝗋EIF (Identity_Element⇩E S) (1 ⊨ S) ›
  unfolding Identity_Element⇩E_def 𝗋EIF_def Transformation_def
  by blast

lemma Identity_Element⇩E_𝒜ESC_sat:
  ‹ 𝗋ESC (1 ⊨ S) (Identity_Element⇩E S) ›
  unfolding Identity_Element⇩E_def 𝗋ESC_def Transformation_def
  by blast

bundle Identity_Element⇩I_sat = Identity_Element⇩I_𝒜EIF_sat [φreason %extract_pure_sat]
                               Identity_Element⇩I_𝒜ESC_sat [φreason %extract_pure_sat]
bundle Identity_Element⇩E_sat = Identity_Element⇩E_𝒜EIF_sat [φreason %extract_pure_sat]
                               Identity_Element⇩E_𝒜ESC_sat [φreason %extract_pure_sat]

bundle Identity_Element_sat begin
  unbundle Identity_Element⇩I_sat Identity_Element⇩E_sat
end


paragraph ‹Identity_Elements›

lemma [φreason %extract_pure]:
  ‹ (⋀x. 𝗋EIF (Identity_Element⇩I (x ⦂ T) (P x)) (Q x))
⟹ 𝗋EIF (Identity_Elements⇩I T D P) (∀x. D x ⟶ Q x)›
  unfolding 𝗋EIF_def Identity_Elements⇩I_def
  by clarsimp

lemma [φreason %extract_pure]:
  ‹ (⋀x. 𝗋EIF (Identity_Element⇩E (x ⦂ T)) (Q x))
⟹ 𝗋EIF (Identity_Elements⇩E T D) (∀x. D x ⟶ Q x) ›
  unfolding 𝗋EIF_def Identity_Elements⇩E_def
  by clarsimp

subsubsection ‹System Rules›

lemma Identity_Elements⇩I_sub:
  ‹ D' ≤ D
⟹ P ≤ P'
⟹ Identity_Elements⇩I T D P 
⟹ Identity_Elements⇩I T D' P' ›
  unfolding Identity_Elements⇩I_def Identity_Element⇩I_def Transformation_def
  by (clarsimp simp add: le_fun_def; blast)

lemma [φreason %cutting]:
  ‹ Identity_Elements⇩I T D⇩I P
⟹ Identity_Elements⇩E T D⇩E
⟹ Identity_Elements T (λx. D⇩I x ∧ D⇩E x) ›
  unfolding Identity_Elements_def
  by (smt (verit, best) Identity_Elements⇩E_def Identity_Elements⇩I_sub predicate1I)


subsubsection ‹Fallback›

(*
lemma [φreason default %identity_element_fallback]:
  ‹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False
⟹ Identity_Element⇩I S False›
  unfolding Premise_def
  by blast

lemma [φreason default %identity_element_fallback]:
  ‹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False
⟹ Identity_Element⇩E S›
  unfolding Premise_def
  by blast
*)

lemma [φreason default %fail]:
  ‹ TRACE_FAIL TEXT(‹Fail to show› (S 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1))
⟹ Identity_Element⇩I S Any ›
  unfolding TRACE_FAIL_def
  by blast

lemma [φreason default %fail]:
  ‹ TRACE_FAIL TEXT(‹Fail to show› (1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S))
⟹ Identity_Element⇩E S ›
  unfolding TRACE_FAIL_def
  by blast

lemma [φreason default %identity_element_fallback]:
  ‹ Identity_Elements⇩I T (λ_. False) (λ_. True) ›
  unfolding Identity_Elements⇩I_def
  by blast

lemma [φreason default %identity_element_fallback]:
  ‹ Identity_Elements⇩E T (λ_. False) ›
  unfolding Identity_Elements⇩E_def
  by blast



subsubsection ‹Termination›

lemma [φreason %identity_element_cut]:
  ‹Identity_Element⇩I 0 True›
  unfolding Identity_Element⇩I_def by simp

lemma [φreason %identity_element_cut for ‹Identity_Element⇩E 1›
                                         ‹Identity_Element⇩E ?var› ]:
  ‹Identity_Element⇩E 1›
  unfolding Identity_Element⇩E_def by simp

lemma [φreason %identity_element_cut for ‹Identity_Element⇩I 1 _›
                                         ‹Identity_Element⇩I ?var _› ]:
  ‹Identity_Element⇩I 1 True›
  unfolding Identity_Element⇩I_def by simp

lemma Identity_Element⇩E_empty[φreason %identity_element_cut]:
  ‹Identity_Element⇩E (any ⦂ ○)›
  unfolding Identity_Element⇩E_def by simp

lemma Identity_Element⇩I_empty[φreason %identity_element_cut]:
  ‹Identity_Element⇩I (any ⦂ ○) True›
  unfolding Identity_Element⇩I_def by simp

lemma [φreason %identity_element_cut]:
  ‹Identity_Element⇩E (any ⦂ ○⇩𝗑)›
  unfolding Identity_Element⇩E_def by simp

lemma [φreason %identity_element_cut]:
  ‹Identity_Element⇩I (any ⦂ ○⇩𝗑) True›
  unfolding Identity_Element⇩I_def by simp

(*
lemma [φreason %identity_element_cut for ‹Identity_Element⇩I {_} _› ]:
  ‹Identity_Element⇩I {1} True›
  unfolding Identity_Element⇩I_def one_set_def by simp

lemma [φreason %identity_element_cut for ‹Identity_Element⇩E {_}›]:
  ‹Identity_Element⇩E {1}›
  unfolding Identity_Element⇩E_def one_set_def by simp
*)


subsubsection ‹Special Forms›

lemma [φreason %identity_element_red for ‹Identity_Element⇩I _ True›]:
  ‹ Identity_Element⇩I X Any
⟹ Identity_Element⇩I X True ›
  unfolding Identity_Element⇩I_def Transformation_def
  by simp

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I X P
⟹ Identity_Element⇩I (φTagA mode X) P ›
  unfolding φTagA_def .

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩E X
⟹ Identity_Element⇩E (φTagA mode X) ›
  unfolding φTagA_def .


paragraph ‹Conditioned Branch›

subparagraph ‹Reduction›

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩I A P
⟹ Identity_Element⇩I (If True A B) P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩I B P
⟹ Identity_Element⇩I (If False A B) P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩E A
⟹ Identity_Element⇩E (If True A B) ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩E B
⟹ Identity_Element⇩E (If False A B) ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩I A D P
⟹ Identity_Elements⇩I (If True A B) D P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩I B D P
⟹ Identity_Elements⇩I (If False A B) D P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩E A D
⟹ Identity_Elements⇩E (If True A B) D ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩E B D
⟹ Identity_Elements⇩E (If False A B) D ›
  by simp


subparagraph ‹Normalizing›

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I (If C (x ⦂ A) (x ⦂ B)) P
⟹ Identity_Element⇩I (x ⦂ If C A B) P›
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩E (If C (x ⦂ A) (x ⦂ B))
⟹ Identity_Element⇩E (x ⦂ If C A B)›
  by (cases C; simp)

subparagraph ‹Case Split›

lemma [φreason %identity_element_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇  C ⟹ Identity_Elements⇩I A D⇩A P⇩A)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬C ⟹ Identity_Elements⇩I B D⇩B P⇩B)
⟹ Identity_Elements⇩I (If C A B) (if C then D⇩A else D⇩B) (if C then P⇩A else P⇩B) ›
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇  C ⟹ Identity_Elements⇩E (If C A B) D⇩A)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬C ⟹ Identity_Elements⇩E (If C A B) D⇩B)
⟹ Identity_Elements⇩E (If C A B) (If C D⇩A D⇩B)›
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Element⇩I A Pa)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ Identity_Element⇩I B Pb)
⟹ Identity_Element⇩I (If C A B) (If C Pa Pb) ›
  by (cases C; simp)

lemma [φreason %identity_element_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Element⇩E A)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ Identity_Element⇩E B)
⟹ Identity_Element⇩E (If C A B) ›
  by (cases C; simp)

paragraph ‹Case Split of Sum Type›

subparagraph ‹Reduction›

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩E (A a)
⟹ Identity_Element⇩E (case_sum A B (Inl a)) ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩E (B b)
⟹ Identity_Element⇩E (case_sum A B (Inr b)) ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩I (A a) P
⟹ Identity_Element⇩I (case_sum A B (Inl a)) P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Element⇩I (B b) P
⟹ Identity_Element⇩I (case_sum A B (Inr b)) P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩E (A a) D
⟹ Identity_Elements⇩E (case_sum A B (Inl a)) D ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩E (B b) D
⟹ Identity_Elements⇩E (case_sum A B (Inr b)) D ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩I (A a) D P
⟹ Identity_Elements⇩I (case_sum A B (Inl a)) D P ›
  by simp

lemma [φreason %identity_element_red]:
  ‹ Identity_Elements⇩I (B b) D P
⟹ Identity_Elements⇩I (case_sum A B (Inr b)) D P ›
  by simp

subparagraph ‹Case Split›

lemma [φreason %identity_element_cut]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ Identity_Element⇩I (A a) (P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ Identity_Element⇩I (B b) (Q b))
⟹ Identity_Element⇩I (case_sum A B x) (pred_sum P Q x) ›
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ Identity_Element⇩E (A a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ Identity_Element⇩E (B b))
⟹ Identity_Element⇩E (case_sum A B x) ›
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ Identity_Elements⇩I (A a) (D⇩A a) (P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ Identity_Elements⇩I (B b) (D⇩B b) (Q b))
⟹ Identity_Elements⇩I (case_sum A B x) (case_sum D⇩A D⇩B x) (case_sum P Q x) ›
  unfolding Premise_def
  by (cases x; clarsimp)

lemma [φreason %identity_element_cut]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ Identity_Elements⇩E (A a) (D⇩A a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ Identity_Elements⇩E (B b) (D⇩B b))
⟹ Identity_Elements⇩E (case_sum A B x) (case_sum D⇩A D⇩B x) ›
  unfolding Premise_def
  by (cases x; clarsimp)



subsubsection ‹ToA Entry Point›

lemma [φreason default ! %identity_element_ToA]:
  ‹ Identity_Element⇩I X P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩I_def Action_Tag_def .

lemma [φreason default ! %identity_element_ToA+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var ⦂ ○ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹ Identity_Element⇩I X P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 () ⦂ ○ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩I_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  ‹ Identity_Element⇩I X P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ ○ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩I_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  ‹ Identity_Element⇩E X
⟹ 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩E_def Action_Tag_def .

lemma [φreason default ! %identity_element_ToA+1 for ‹?var ⦂ ○ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹ Identity_Element⇩E X
⟹ () ⦂ ○ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩E_def Action_Tag_def
  by simp

lemma [φreason default ! %identity_element_ToA]:
  ‹ Identity_Element⇩E X
⟹ x ⦂ ○ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒯𝒫 ›
  unfolding Identity_Element⇩E_def Action_Tag_def
  by simp


subsubsection ‹Logic Connectives \& Basic φ-Types›

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩I Itself (λx. x = 1) (λ_. True) ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩E Itself (λx. x = 1) ›
  unfolding Identity_Element⇩E_def Identity_Elements⇩E_def Transformation_def
  by clarsimp

lemma [φreason no explorative backtrack %identity_element_φ]:
  ‹ Identity_Elements⇩I T D P
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
⟹ Identity_Element⇩I (x ⦂ T) (P x) ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def Premise_def
  using transformation_trans by fastforce

lemma [φreason no explorative backtrack %identity_element_φ+1 for ‹Identity_Element⇩I (?var ⦂ _) _›]:
  ‹ Identity_Elements⇩I T D P
⟹ Hint_Identity_Element T x ∨⇩c⇩u⇩t True
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
⟹ Identity_Element⇩I (x ⦂ T) (P x) ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def Premise_def
            Orelse_shortcut_def Ant_Seq_def
  using transformation_trans by fastforce

lemma [φreason no explorative backtrack %identity_element_φ]:
  ‹ Identity_Elements⇩E T D
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 D x
⟹ Identity_Element⇩E (x ⦂ T) ›
  unfolding Identity_Element⇩E_def Identity_Elements⇩E_def Premise_def
  using transformation_trans by fastforce

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I A P1
⟹ Identity_Element⇩I B P2
⟹ Identity_Element⇩I (A + B) (P1 ∨ P2)›
  unfolding Identity_Element⇩I_def Transformation_def
  by simp

lemma (*The above rule is local complete*)
  ‹Identity_Element⇩I (A + B) P ⟹ Identity_Element⇩I A P ∧ Identity_Element⇩I B P›
  unfolding Identity_Element⇩I_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩E A ∨ Identity_Element⇩E B
⟹ Identity_Element⇩E (A + B)›
  unfolding Identity_Element⇩E_def Transformation_def
  by clarsimp

lemma (*The above rule is not local complete*)
  ‹ Identity_Element⇩E (A + B) ⟹ Identity_Element⇩E A ∧ Identity_Element⇩E B›
  oops

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I (A x) P
⟹ Identity_Element⇩I (AllSet A) P›
  unfolding Identity_Element⇩I_def
  by (metis AllSet_expn Transformation_def)
(*The rule is not local complete*)

lemma [φreason %identity_element_cut]:
  ‹ (⋀x. Identity_Element⇩E (A x))
⟹ Identity_Element⇩E (AllSet A)›
  unfolding Identity_Element⇩E_def
  by (metis AllSet_expn Transformation_def)

lemma (*The above rule is local complete*)
  ‹ Identity_Element⇩E (AllSet A) ⟹ Identity_Element⇩E (A x) ›
  unfolding Identity_Element⇩E_def Transformation_def
  by clarsimp

lemma [φreason %identity_element_cut]:
  ‹(⋀x. Identity_Element⇩I (A x) (P x))
⟹ Identity_Element⇩I (ExSet A) (Ex P)›
  unfolding Identity_Element⇩I_def
  by (metis ExSet_expn Transformation_def)

lemma (*The above rule is local complete*)
  ‹Identity_Element⇩I (ExSet A) P ⟹ Identity_Element⇩I (A x) P›
  unfolding Identity_Element⇩I_def Transformation_def
  by (clarsimp; blast)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩E (A x)
⟹ Identity_Element⇩E (ExSet A)›
  unfolding Identity_Element⇩E_def Transformation_def
  by (clarsimp; blast)

lemma (*The above rule is not local complete*)
  ‹Identity_Element⇩E (ExSet A) ⟹ ∃x. Identity_Element⇩E (A x)›
  unfolding Identity_Element⇩E_def Transformation_def ExSet_expn
  by clarsimp

lemma [φreason %identity_element_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P ⟹ Identity_Element⇩I A Q)
⟹ Identity_Element⇩I (A 𝗌𝗎𝖻𝗃 P) (P ∧ Q)›
  unfolding Identity_Element⇩I_def Transformation_def
  by (simp; blast)

lemma
  ‹ Identity_Element⇩I (A 𝗌𝗎𝖻𝗃 P) (P ∧ Q) ⟹ (P ⟹ Identity_Element⇩I A Q)›
  unfolding Identity_Element⇩I_def Transformation_def Satisfiable_def
  by (cases P; clarsimp)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩E A
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ Identity_Element⇩E (A 𝗌𝗎𝖻𝗃 P)›
  unfolding Identity_Element⇩E_def Transformation_def Premise_def
  by (clarsimp; blast)

lemma (*The above rule is local complete*)
  ‹ Identity_Element⇩E (A 𝗌𝗎𝖻𝗃 P) ⟹ P ∧ Identity_Element⇩E A ›
  unfolding Identity_Element⇩E_def Transformation_def Premise_def
  by (clarsimp; blast)

lemma [φreason %identity_element_cut]: 
  ‹ Identity_Element⇩I A P
⟹ Identity_Element⇩I B Q
⟹ Identity_Element⇩I (A * B) (P ∧ Q) ›
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Identity_Element⇩I_def Transformation_def
  by (clarsimp simp add: set_mult_expn, insert mult_1_class.mult_1_left; blast)
  (* It is not complete, example: algebra {e,a} where the sep conjunction is only defined
     on the unit, x ## y ⟷ x = e ∧ y = e.
     Let A = B = {e,a}, we have A * B = {e}. Both A B are not stateless but A * B is. *)

lemma [φreason %identity_element_cut]: 
  ‹ Identity_Element⇩E A
⟹ Identity_Element⇩E B
⟹ Identity_Element⇩E (A * B) ›
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Identity_Element⇩E_def Transformation_def
  by (clarsimp, insert mult_1_class.mult_1_left sep_magma_1_left, blast)

lemma (*the above rule is not local complete*)
  ‹ Identity_Element⇩E (A * B) ⟹ Identity_Element⇩E A ∧ Identity_Element⇩E B ›
  for A :: ‹'a::sep_magma_1 BI›
  oops

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩I T D⇩T P
⟹ Identity_Elements⇩I U D⇩U Q
⟹ Identity_Elements⇩I (T ∗ U) (λ(x,y). D⇩T x ∧ D⇩U y) (λ(x,y). P x ∧ Q y)›
  for T :: ‹('a::sep_magma_1, 'b) φ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def φProd_expn' Transformation_def
  by (simp add: set_mult_expn, insert mult_1_class.mult_1_left, blast)

lemma [φreason %identity_element_cut]: 
  ‹ Identity_Elements⇩E T D⇩T
⟹ Identity_Elements⇩E U D⇩U
⟹ Identity_Elements⇩E (T ∗ U) (λ(x,y). D⇩T x ∧ D⇩U y) ›
  for T :: ‹'a ⇒ 'b::sep_magma_1 BI›
  unfolding Identity_Element⇩E_def Identity_Elements⇩E_def Transformation_def
  by (clarsimp simp add: φProd_expn', insert set_mult_expn, fastforce)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩I T D⇩T P
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Elements⇩I U D⇩U Q)
⟹ Identity_Elements⇩I (T ∗[C] U) (λ(x,y). D⇩T x ∧ (C ⟶ D⇩U y)) (λ(x,y). P x ∧ (C ⟶ Q y)) ›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def Transformation_def Premise_def
  by (cases C; clarsimp simp add: φProd_expn'; insert mult_1_class.mult_1_right; blast)

lemma [φreason %identity_element_cut]: 
  ‹ Identity_Element⇩E A
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Element⇩E B)
⟹ Identity_Element⇩E (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) ›
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Identity_Element⇩E_def Transformation_def REMAINS_def
  by (clarsimp, insert mult_1_class.mult_1_left sep_magma_1_left, blast)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I A P
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Element⇩I B Q)
⟹ Identity_Element⇩I (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) (P ∧ (C ⟶ Q)) ›
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Identity_Element⇩I_def Transformation_def Premise_def REMAINS_def
  by (clarsimp, insert mult_1_class.mult_1_right, blast)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩E T D⇩T
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Identity_Elements⇩E U D⇩U)
⟹ Identity_Elements⇩E (T ∗[C] U) (λ(x,y). D⇩T x ∧ (C ⟶ D⇩U y)) ›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding Identity_Element⇩E_def Identity_Elements⇩E_def Transformation_def Premise_def
  by (cases C; clarsimp simp add: φProd_expn'; insert mult_1_class.mult_1_right sep_magma_1_left; blast)

lemma [φreason %identity_element_cut]: 
  ‹ Identity_Element⇩E A
⟹ Identity_Element⇩E B
⟹ Identity_Element⇩E (A ∧⇩B⇩I B) ›
  unfolding Identity_Element⇩E_def Transformation_def
  by (clarsimp)

lemma (*the above rule is local complete*)
  ‹ Identity_Element⇩E (A ∧⇩B⇩I B) ⟹ Identity_Element⇩E A ∧ Identity_Element⇩E B ›
  unfolding Identity_Element⇩E_def Transformation_def
  by (clarsimp)

lemma [φreason %identity_element_cut]:
  ‹ Identity_Element⇩I A P ∨ Identity_Element⇩I B Q
⟹ Identity_Element⇩I (A ∧⇩B⇩I B) (P ∨ Q)›
  unfolding Identity_Element⇩I_def Transformation_def
  by (clarsimp, blast)

lemma (*the above rule is not local complete*)
  ‹ Identity_Element⇩I (A ∧⇩B⇩I B) True ⟹ Identity_Element⇩I A True ∨ Identity_Element⇩I B True ›
  oops
  (* Auto Quickcheck found a counterexample:
  A = {a⇩3}
  B = {a⇩1} *)

lemma [φreason %identity_element_cut]:
  ‹ (⋀i∈I. Identity_Element⇩I (A i) (P i))
⟹ Identity_Element⇩I (✱i∈I. A i) (∀i∈I. P i)›
  unfolding Identity_Element⇩I_def Mul_Quant_def Transformation_def meta_Ball_def Premise_def
proof clarsimp
  fix v
  assume prems: ‹(⋀i. i ∈ I ⟹ ∀v. v ⊨ A i ⟶ v = 1 ∧ P i)›
                ‹v ⊨ prod A I›
     and ‹finite I›
  show ‹v = 1 ∧ (∀x∈I. P x)›
    by (insert prems; induct rule: finite_induct[OF ‹finite I›]; clarsimp; fastforce)
qed

lemma [φreason %identity_element_cut]:
  ‹ (⋀i∈S. Identity_Element⇩E (A i))
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 finite S
⟹ Identity_Element⇩E (✱i∈S. A i) ›
  unfolding Identity_Element⇩E_def Mul_Quant_def Transformation_def Premise_def meta_Ball_def
proof clarsimp
  fix v
  assume prems: ‹(⋀i. i ∈ S ⟹ 1 ⊨ A i)›
     and ‹finite S›
  show ‹1 ⊨ prod A S›
    by (insert prems;
        induct rule: finite_induct[OF ‹finite S›];
        clarsimp;
        (insert mult_1_class.mult_1_left sep_magma_1_right, blast))
qed

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩I (◒[C] T) (λ_. ¬ C) (λ_. True) ›
  unfolding Identity_Element⇩I_def Identity_Elements⇩I_def Transformation_def Premise_def
  by simp

lemma [φreason %identity_element_cut]:
  ‹ Identity_Elements⇩E (◒[C] T) (λ_. ¬ C) ›
  unfolding Identity_Element⇩E_def Identity_Elements⇩E_def Transformation_def Premise_def
  by clarsimp

lemma prevent_eliminate_IEE_φCond_Unital[no_atp]:
  ‹ False
⟹ Identity_Elements⇩E (◒[C] T) Any ›
  by blast

lemma prevent_eliminate_IEI_φCond_Unital[no_atp]:
  ‹ False
⟹ Identity_Elements⇩I (◒[C] T) Any Any' ›
  by blast

bundle prevent_eliminate_IE_φCond_Unital =
  prevent_eliminate_IEE_φCond_Unital[φreason %identity_element_top]
  prevent_eliminate_IEI_φCond_Unital[φreason %identity_element_top]


subsection ‹Equivalence of Objects›

definition Object_Equiv :: ‹('c,'a) φ ⇒ ('a ⇒ 'a ⇒ bool) ⇒ bool›
  where ‹Object_Equiv T eq ⟷ (∀x. eq x x) ∧ (∀x y. eq x y ⟶ (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T))›

text ‹φ-Deriver usually derives the object reachability relation of φ-type operators generally
  for any variable type operand, but the reachability can be wider on specific type operands, such
  as the reachability ‹λx y. True› of ‹List(○)› versus the version ‹λx y. length x = length y› instantiated
  from the general rule ‹Object_Equiv T eq ⟹ Object_Equiv (List T) (list_rel eq)› by substituting
  ‹T› for ‹○› and ‹eq› for ‹(=)›.

  These special `singular` cases are hard to be handled by φ-type algebra who provides a general automation,
  thus demanding user rules for override. Even so, common singular cases can still be handled by ad-hoc
  optimization in the algorithm.

  Generally, when an instantiation of a type operand yields a trivial type relating empty concrete objects,
  a singular case can occur. Therefore, when we infer the reachability of a given type, we can first
  check if it is such a trivial type and if so we derive the wider relation by rule (see ‹𝒜_singular_unit›).
  In this way, the overall reasoning can still be powerful even when such common singular cases are not considered.


(paper)
›

declare [[
  φreason_default_pattern ‹Object_Equiv ?T _› ⇒ ‹Object_Equiv ?T _› (100),
  φpremise_attribute once? [φreason? %local] for ‹Object_Equiv _ _›       (%φattr)
]]

φreasoner_group object_equiv = (100, [1, 3999]) for ‹Object_Equiv T eq›
    ‹Reasoning rules giving the equivalence relation (though is actually a reachability
     relation) of objects of the given φ-type.›
 and object_equiv_cut = (%cutting, [%cutting, %cutting+10]) for ‹Object_Equiv T eq› in object_equiv
    ‹Cutting rules for reasonig Object_Equiv›
 and derived_object_equiv = (50, [50,50]) for ‹Object_Equiv T eq› in object_equiv and < object_equiv_cut
    ‹Automatically derived rules for Object_Equiv›
 and object_equiv_fallback = (1, [1,1]) for ‹Object_Equiv T eq› in object_equiv and < derived_object_equiv
    ‹Fallback rules for reasonig Object_Equiv›

subsubsection ‹Variants›

consts 𝒜_singular_unit :: action

declare [[
  φreason_default_pattern ‹Object_Equiv ?T _ @tag 𝒜_singular_unit› ⇒
                          ‹Object_Equiv ?T _ @tag 𝒜_singular_unit› (100)
]]

lemma [φreason %object_equiv_cut+1]:
  ‹ Identity_Elements⇩I T D⇩I P
⟹ Identity_Elements⇩E T D⇩E
⟹ Object_Equiv T eq
⟹ Object_Equiv T (λx y. eq x y ∨ D⇩I x ∧ (P x ⟶ D⇩E y)) @tag 𝒜_singular_unit ›
  unfolding Object_Equiv_def Identity_Elements⇩E_def Identity_Elements⇩I_def Action_Tag_def
            Transformation_def Identity_Element⇩I_def Identity_Element⇩E_def
  by clarsimp blast

lemma [φreason %object_equiv_cut]: ― ‹for non-unital algebras›
  ‹ Object_Equiv T eq
⟹ Object_Equiv T eq @tag 𝒜_singular_unit ›
  unfolding Action_Tag_def
  by clarsimp


subsubsection ‹Its Role in ToA›

(*
lemma [φreason default %ToA_varify_target_object for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗐𝗂𝗍𝗁 _›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗐𝗂𝗍𝗁 _› ]:
  ‹ Object_Equiv U eq
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq y y' ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P))
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq y y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗐𝗂𝗍𝗁 P ›
  unfolding Object_Equiv_def Transformation_def Premise_def Action_Tag_def Orelse_shortcut_def
            Identity_Elements⇩E_def Identity_Element⇩E_def Identity_Element⇩I_def Identity_Elements⇩I_def
            Ant_Seq_def Premise_def
  by clarsimp
*)

(*
(*It is some historical remain that I forget whether I can remove it safely.
  The reasoning about identity element should have been solved by the falling lattice completely,
  so the commented reasoning rules should be able to be removed safely, but I am not sure, and rechecking
  is demanded later.
*)
lemma [φreason default %ToA_varify_target_object for ‹(_::?'c::one BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗐𝗂𝗍𝗁 _›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ Identity_Elements⇩E U D⇩E
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] (D⇩E y')) ∧⇩𝗋 Identity_Element⇩I X P ∨⇩c⇩u⇩t
    Identity_Elements⇩I U D⇩I P⇩I ∧⇩𝗋
    Object_Equiv U eq ∧⇩𝗋
    (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq y y' ∨ D⇩I y ∧ (P⇩I y ⟶ D⇩E y') ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P)) ∧⇩𝗋
    (𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq y y' ∨ D⇩I y ∧ (P⇩I y ⟶ D⇩E y'))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗐𝗂𝗍𝗁 P ›
  unfolding Object_Equiv_def Transformation_def Premise_def Action_Tag_def Orelse_shortcut_def
            Identity_Elements⇩E_def Identity_Element⇩E_def Identity_Element⇩I_def Identity_Elements⇩I_def
            Ant_Seq_def Premise_def
  by clarsimp blast
*)
(*
lemma ToA_by_Equiv_Class:
  ‹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 eq_y_y' : eq y y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P
  ― ‹⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq_y_y' ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P)
      deprecated: the target object is always constrained even when it can be variable›
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq_y_y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗐𝗂𝗍𝗁 P ›
  unfolding Object_Equiv_def Transformation_def Premise_def Action_Tag_def Simplify_def
  by clarsimp
*)
(*
lemma [φreason default %ToA_varify_target_object for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ Object_Equiv U eq
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq y y' ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P))
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq y y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  unfolding Object_Equiv_def Transformation_def Premise_def REMAINS_def Action_Tag_def Simplify_def
  by (cases C; clarsimp; meson Transformation_def transformation_left_frame)
*)

(*
(*TODO: re-enable!*)
lemma [φreason default %ToA_varify_target_object for ‹(_::?'c::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ Identity_Elements⇩E U D⇩E
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] (D⇩E y')) ∧⇩𝗋 (C,R,P) = (True,X,True) ∨⇩c⇩u⇩t
    Identity_Elements⇩I U D⇩I P⇩I ∧⇩𝗋
    Object_Equiv U eq ∧⇩𝗋
    (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq y y' ∨ D⇩I y ∧ (P⇩I y ⟶ D⇩E y') ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P)) ∧⇩𝗋
    (𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq y y' ∨ D⇩I y ∧ (P⇩I y ⟶ D⇩E y'))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  for X :: ‹'c::sep_magma_1 BI›
  unfolding Object_Equiv_def Transformation_def Premise_def REMAINS_def Action_Tag_def
            Identity_Elements⇩E_def Identity_Elements⇩I_def Identity_Element⇩E_def Identity_Element⇩I_def
            Orelse_shortcut_def Ant_Seq_def
  by (cases C; clarsimp; metis mult_1_class.mult_1_right sep_magma_1_left)
*)
(*
lemma ToA_by_Equiv_Class':
   (* [φreason default %ToA_varify_target_object for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›
                                              except ‹(_::?'c::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›
                                                     ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]: *)
  ‹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 eq_y_y' : eq y y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
― ‹⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq_y_y' ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P)›
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq_y_y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  unfolding Object_Equiv_def Transformation_def Premise_def REMAINS_def Action_Tag_def Simplify_def
  by (cases C; clarsimp; meson Transformation_def transformation_left_frame)
*)

subsubsection ‹Extracting Pure Facts›

lemma [φreason %extract_pure]:
  ‹ (⋀x y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq x y ⟹ 𝗋EIF (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T) (P x y) )
⟹ 𝗋EIF (Object_Equiv T eq) ((∀x. eq x x) ∧ (∀x y. eq x y ⟶ P x y))›
  unfolding 𝗋EIF_def Object_Equiv_def Premise_def Transformation_def
  by clarsimp

lemma [φreason %extract_pure]:
  ‹ (⋀x y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 eq x y ⟹ 𝗋ESC (P x y) (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T))
⟹ 𝗋ESC ((∀x. eq x x) ∧ (∀x y. eq x y ⟶ P x y)) (Object_Equiv T eq) ›
  unfolding 𝗋ESC_def Object_Equiv_def Premise_def Transformation_def
  by clarsimp


subsubsection ‹Reasoning Rules›

lemma Object_Equiv_fallback[φreason default %object_equiv_fallback]:
  ‹Object_Equiv T (=)›
  unfolding Object_Equiv_def by simp


(*
lemma [φreason 800 for ‹?x ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?y ⦂ ?T' 𝗐𝗂𝗍𝗁 _›]:
  " Object_Equiv T eq
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 eq x y
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T"
  unfolding Object_Equiv_def Transformation_def Premise_def by clarsimp*)

lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv ○ (λ_ _. True) ›
  unfolding Object_Equiv_def Transformation_def
  by simp

lemma [φreason %object_equiv_cut]:
  ‹ (⋀a. Object_Equiv (λx. S x a) (R a))
⟹ Object_Equiv (λx. ExSet (S x)) (λx y. ∀a. R a x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp; blast)

lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv S R
⟹ Object_Equiv (λx. S x 𝗌𝗎𝖻𝗃 P x) (λx y. P x ⟶ R x y ∧ P y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv S1 R1
⟹ Object_Equiv S2 R2
⟹ Object_Equiv (λx. S1 x ∧⇩B⇩I S2 x) (λx y. R1 x y ∧ R2 x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv S1 R1
⟹ Object_Equiv S2 R2
⟹ Object_Equiv (λx. S1 x + S2 x) (λx y. R1 x y ∧ R2 x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp

(* lemma
  ‹ (⋀x. Object_Equiv (R x) (T x))
⟹ Object_Equiv (λx y. T y = T x ∧ R x (f x) (f y)) (λx. f x ⦂ T x)›
  unfolding Object_Equiv_def Transformation_def φType_def
  by clarsimp *)

lemma [φreason %object_equiv_cut]:
  ‹ (⋀a. Object_Equiv (λx. S x a) (R a))
⟹ Object_Equiv (λx. AllSet (S x)) (λx y. ∀a. R a x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp simp add: AllSet_expn; blast)

lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv S1 R1
⟹ Object_Equiv S2 R2
⟹ Object_Equiv (λx. S1 x * S2 x) (λ x y. R1 x y ∧ R2 x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp simp add: set_mult_expn; blast)

(* ― ‹derived automatically later›
lemma [φreason %object_equiv_cut]:
  ‹ Object_Equiv T⇩a Eq⇩a
⟹ Object_Equiv T⇩b Eq⇩b
⟹ Object_Equiv (T⇩a ∗ T⇩b) (λ(x⇩a, x⇩b) (y⇩a, y⇩b). Eq⇩a x⇩a y⇩a ∧ Eq⇩b x⇩b y⇩b) ›
  unfolding Object_Equiv_def Transformation_def
  by (clarsimp simp add: set_mult_expn; blast)
*)

(*
lemma
  ‹ (⋀x y. Rx x y ⟷ (S1 x * S2 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S1 y * S2 y))
⟹ (⋀x y. R1 x y ⟷ (S1 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S1 y))
⟹ (⋀x y. R2 x y ⟷ (S2 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S2 y))
⟹ (⋀x y. Rx x y ⟹ R1 x y ∨ R2 x y)›
  unfolding Transformation_def
  apply (auto simp add: set_mult_expn)*)

lemma
  ‹ Object_Equiv S1 R1
⟹ Object_Equiv S2 R2
⟹ Object_Equiv (λx. {p. p ⊨ S1 x ⟶ p ⊨ S2 x}) (λx y. R1 y x ∧ R2 x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  by (clarsimp simp add: Satisfaction_def)

lemma [φreason %object_equiv_cut]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ Object_Equiv A Ea)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ Object_Equiv B Eb)
⟹ Object_Equiv (if C then A else B) (if C then Ea else Eb) ›
  unfolding Premise_def
  by (cases C; simp)

(*
lemma
  ‹ (⋀x y. Rx x y ⟷ ({p. p ∈ S1 x ⟶ p ∈ S2 x} 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 {p. p ∈ S1 y ⟶ p ∈ S2 y}))
⟹ (⋀x y. R1 x y ⟷ (S1 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S1 y))
⟹ (⋀x y. R2 x y ⟷ (S2 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S2 y))
⟹ (⋀x y. Rx x y ⟹ R1 y x ∧ R2 x y) ›
  unfolding Object_Equiv_def Transformation_def φType_def
  apply (auto simp add: AllSet_expn)*)

(*
lemma
  ‹ (⋀x y. Rx x y ⟷ (S1 x ∪ S2 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S1 y ∩ S2 y))
⟹ (⋀x y. R1 x y ⟷ (S1 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S1 y))
⟹ (⋀x y. R2 x y ⟷ (S2 x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 S2 y))
⟹ (⋀x y. Rx x y ⟹ R1 x y ∧ R2 x y)›
  unfolding Transformation_def
  apply (auto simp add: Subjection_expn) *)


lemma Object_Equiv_Mul_Quant[φreason %object_equiv_cut]:
  ‹ (∀i x. eq i x x)
⟹ (⋀i∈S. Object_Equiv (λx. A x i) (eq i))
⟹ Object_Equiv (λx. ✱i∈S. A x i) (λx y. ∀i. eq i x y)›
  unfolding Object_Equiv_def Transformation_def φType_def
            meta_Ball_def Premise_def Mul_Quant_def
  proof (clarsimp, unfold Satisfaction_def)
    fix x y v
    assume prems: ‹(⋀x. x ∈ S ⟹ ∀xa y. eq x xa y ⟶ (∀v. v ∈ A xa x ⟶ v ∈ A y x))›
                  ‹∀i. eq i x y›
                  ‹v ∈ prod (A x) S›
       and ‹finite S›
    show ‹v ∈ prod (A y) S›
      by (insert prems;
          induct arbitrary: x y v rule: finite_induct[OF ‹finite S›];
          clarsimp simp add: set_mult_expn;
          metis)
  qed

section ‹Reasoning›

ML_file ‹library/syntax/Phi_Syntax0.ML›

subsection ‹Preliminary›

subsubsection ‹Mapping φ-Type Items by Transformation›

consts 𝒜_map_each_item :: ‹action ⇒ action›

declare [[φreason_default_pattern
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item _› ⇒
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item _›    (100)
  and ‹?X @tag 𝒜_map_each_item ?𝒜 › ⇒
      ‹ERROR TEXT(‹Bad Rule: › (?X @tag 𝒜_map_each_item ?𝒜)) ›    (0)
]]

φreasoner_group 𝒜_map_each_item = (1050, [1010, 3000]) for (‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item 𝒜›)
      ‹Reasoning rules applying action ‹𝒜› onto each atomic items in ‹X››
  and 𝒜_map_each_item_fallback = (1000, [1000, 1000]) for (‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_map_each_item 𝒜›)
      ‹Fallback rules ending 𝒜_map_each_item›

paragraph ‹Implementation›

lemma [φreason %𝒜_map_each_item]:
  ‹ 1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 1 @tag 𝒜_map_each_item A ›
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  ‹ 0 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 0 @tag 𝒜_map_each_item A ›
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  ‹ ⊤ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ⊤ @tag 𝒜_map_each_item A ›
  unfolding Action_Tag_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  ‹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
⟹ X 𝗌𝗎𝖻𝗃 Q 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗌𝗎𝖻𝗃 Q 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A›
  unfolding Action_Tag_def Premise_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
⟹ A ∧⇩B⇩I B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X ∧⇩B⇩I Y 𝗐𝗂𝗍𝗁 P ∧ Q @tag 𝒜_map_each_item 𝒜›
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
⟹ A + B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X + Y 𝗐𝗂𝗍𝗁 P ∨ Q @tag 𝒜_map_each_item 𝒜›
  unfolding Action_Tag_def Transformation_def
  by simp

lemma [φreason %𝒜_map_each_item]:
  ‹ (⋀c. X c 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y c 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
⟹ ExSet X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExSet Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A›
  unfolding Action_Tag_def
  using ExSet_transformation .

lemma [φreason %𝒜_map_each_item]:
  ‹ (⋀c. X c 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y c 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A)
⟹ AllSet X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 AllSet Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A›
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜
⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗐𝗂𝗍𝗁 P ∧ Q @tag 𝒜_map_each_item 𝒜 ›
  unfolding Action_Tag_def Transformation_def
  by simp blast

lemma [φreason %𝒜_map_each_item]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A
⟹ W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item A
⟹ X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ∧ (C ⟶ Q) @tag 𝒜_map_each_item A›
  unfolding REMAINS_def
  by (cases C; simp add: Action_Tag_def transformation_bi_frame;
      metis transformation_bi_frame transformation_weaken)

lemma [φreason %𝒜_map_each_item]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A' 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item 𝒜)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B' 𝗐𝗂𝗍𝗁 Q @tag 𝒜_map_each_item 𝒜)
⟹ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A' B' 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒜_map_each_item 𝒜›
  unfolding Action_Tag_def Premise_def
  by (cases C; simp)

lemma [φreason %𝒜_map_each_item]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A' a 𝗐𝗂𝗍𝗁 P a @tag 𝒜_map_each_item 𝒜)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B' b 𝗐𝗂𝗍𝗁 Q b @tag 𝒜_map_each_item 𝒜)
⟹ (case_sum A B x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (case_sum A' B' x) 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒜_map_each_item 𝒜›
  unfolding Action_Tag_def Premise_def
  by (cases x; simp)

lemma [φreason %𝒜_map_each_item]:
  ‹ (⋀i∈I. A i 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B i 𝗐𝗂𝗍𝗁 P i @tag 𝒜_map_each_item 𝒜)
⟹ (✱i∈I. A i) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (✱i∈I. B i) 𝗐𝗂𝗍𝗁 (∀i ∈ I. P i) @tag 𝒜_map_each_item 𝒜 ›
  unfolding Action_Tag_def Premise_def
  by (clarsimp simp add: sep_quant_transformation)

lemma [φreason %𝒜_map_each_item_fallback]: ― ‹fallback›
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag A
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜_map_each_item A›
  unfolding Action_Tag_def .


subsection ‹Normalization of Assertions›

subsubsection ‹Declaring Simpsets›

consts assertion_simps :: ‹mode ⇒ mode›
       SOURCE :: mode
       TARGET :: mode

ML ‹
structure Assertion_SS = Simpset (
  val initial_ss = Simpset_Configure.Minimal_SS
  val binding = SOME \<^binding>‹assertion_simps›
  val comment = "Simplification rules normalizing an assertion. \
                       \It is applied before NToA process."
  val attribute = NONE
  val post_merging = I
)

val _ = Theory.setup (Context.theory_map (Assertion_SS.map (fn ctxt =>
      (ctxt addsimprocs [\<^simproc>‹NO_MATCH›, \<^simproc>‹defined_Ex›, \<^simproc>‹HOL.defined_All›,
                         \<^simproc>‹defined_all›, \<^simproc>‹defined_Collect›, \<^simproc>‹Set.defined_All›,
                         \<^simproc>‹Set.defined_Bex›, \<^simproc>‹unit_eq›, \<^simproc>‹case_prod_beta›,
                         \<^simproc>‹case_prod_eta›, \<^simproc>‹Collect_mem›,
                         Phi_Conv.move_Ex_for_set_notation]
            addsimps @{thms' Sum_Type.sum.case HOL.simp_thms})
          (*|> Simplifier.add_cong @{thm' Subjection_cong}*)
    )))

structure Assertion_SS_Source = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = SOME \<^binding>‹assertion_simps_source›
  val comment = "Simp rules normalizing particularly source part of an assertion."
  val attribute = NONE
  val post_merging = I
)

val _ = Theory.setup (Context.theory_map (Assertion_SS_Source.map (fn ctxt =>
      ctxt addsimps @{thms' ExSet_defined}
        |> Simplifier.add_cong @{thm' Subjection_cong}
    )))

structure Assertion_SS_Target = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = SOME \<^binding>‹assertion_simps_target›
  val comment = "Simp rules normalizing particularly target part of an assertion."
  val attribute = NONE
  val post_merging = I
)
›

lemmas [assertion_simps] =
  (*algebras*)
  mult_zero_right[where 'a=‹'a::sep_magma BI›] mult_zero_left[where 'a=‹'a::sep_magma BI›]
  mult_1_right[where 'a=‹'a::sep_magma_1 BI›]
  mult_1_left[where 'a=‹'a::sep_magma_1 BI›]
  add_0_right[where 'a=‹'a::sep_magma BI›] add_0_left[where 'a=‹'a::sep_magma BI›]
  zero_fun zero_fun_def[symmetric, where 'b=‹'a::sep_magma BI›]
  plus_fun[where 'a=‹'a::sep_magma BI›]
  distrib_right[where 'a=‹'a::sep_semigroup BI›]
  mult.assoc[where 'a=‹'a::sep_semigroup BI›]
  bot_eq_BI_bot

  (*BI connectives*)
  Subjection_Subjection Subjection_Zero Subjection_True Subjection_Flase
  Subjection_times Subjection_addconj

  ExSet_simps ExSet_split_prod ExSet_subj_split_prod

  sep_quant_subjection sep_quant_ExSet

  φProd_expn'' φProd_expn'
  REMAINS_simp(2)
  HOL.if_True HOL.if_False

  φBot.unfold φAny.unfold

  (*Usual simps*)
  fst_conv snd_conv

lemmas [assertion_simps_source] =
  ExSet_times_left ExSet_times_right ExSet_adconj ExSet_addisj

  REMAINS_simp(1)

  sep_quant_sep

lemmas [assertion_simps_target] =
  sep_quant_sep[symmetric]

lemmas [φprogramming_base_simps, φprogramming_simps, φsafe_simp] =
  add_0_right[where 'a=‹'a::sep_magma set›] add_0_left[where 'a=‹'a::sep_magma set›]
  zero_fun_def[symmetric, where 'b=‹'a::sep_magma BI›]
  plus_fun[where 'a=‹'a::sep_magma BI›]
  distrib_right[where 'a=‹'a::sep_semigroup BI›]
  mult.assoc[where 'a=‹'a::sep_semigroup BI›]

lemmas [φprogramming_base_simps] =
  mult_zero_right[where 'a=‹'a::sep_magma set›] mult_zero_left[where 'a=‹'a::sep_magma set›]
  mult_1_right[where 'a=‹'a::sep_magma_1 set›] mult_1_left[where 'a=‹'a::sep_magma_1 set›]
  zero_fun

  HOL.simp_thms

  REMAINS_simp(2)
  HOL.if_True HOL.if_False


ML_file ‹library/reasoning/quantifier.ML›

simproc_setup defined_ExSet ( ‹ExSet A› ) = ‹K BI_Quantifiers.defined_Ex›

setup ‹Context.theory_map (Phi_Programming_Simp_Hook.add 100 (fn () => fn ctxt =>
    ctxt delsimprocs [@{simproc defined_ExSet}]
         delsimps @{thms' ExSet_defined}))
›

(*
setup ‹Context.theory_map (Simplifier.map_ss(fn ctxt =>
    ctxt delsimprocs [@{simproc defined_ExSet}]))›

attribute_setup simproc_defined_ExSet = ‹
  Scan.lift (Args.$$$ "true" >> K true || Args.$$$ "false" >> K false || Scan.succeed true)
>> (fn flag =>
    Thm.declaration_attribute (fn _ => Simplifier.map_ss(fn ctxt =>
      if flag then ctxt addsimprocs [@{simproc defined_ExSet}]
              else ctxt delsimprocs [@{simproc defined_ExSet}])))
›
*)

(*
simproc_setup defined_ExSet ( ‹ExSet A› )
  = ‹fn _ => fn ctxt => fn ctm =>
      case Thm.term_of ctm
        of Const(\<^const_name>‹ExSet›, _) $ Abs (_, _, Const(\<^const_name>‹Subjection›, _) $ assn $ P) =>
      let val Const(\<^const_name>‹ExSet›, _) $ X = Thm.term_of ctm
          val chk_bound_only_objs = Phi_Syntax.forall_item_of_assertion (
                  fn (Const(\<^const_name>‹φType›, _) $ x $ T) => not (Term.is_dependent T)
                   | X => not (Term.is_dependent X)
                )
          val rule = case P
                       of Const(\<^const_name>‹HOL.eq›, _) $ Bound 0 $ _ =>
                            SOME @{thm' ExSet_defined(1)}
                        | Const(\<^const_name>‹HOL.eq›, _) $ _ $ Bound 0 =>
                            SOME @{thm' ExSet_defined(2)}
                        | Const(\<^const_name>‹HOL.conj›, _) $ (Const(\<^const_name>‹HOL.eq›, _) $ Bound 0 $ _) $ _ =>
                            SOME @{thm' ExSet_defined(3)}
                        | Const(\<^const_name>‹HOL.conj›, _) $ (Const(\<^const_name>‹HOL.eq›, _) $ _ $ Bound 0) $ _ =>
                            SOME @{thm' ExSet_defined(4)}
                        | _ => NONE
       in if chk_bound_only_objs assn
       then Option.mapPartial (fn rule' => try (Conv.rewr_conv rule') ctm) rule
       else NONE
      end
        | _ => NONE›
*)

setup ‹Context.theory_map (
  Assertion_SS_Source.map (fn ctxt =>
    ctxt addsimprocs [@{simproc defined_ExSet}] ) #>
  Assertion_SS.map (fn ctxt =>
    ctxt addsimprocs [@{simproc Funcomp_Lambda}]) #>
  Phi_Safe_Simps.map (fn ctxt =>
    ctxt addsimprocs [@{simproc defined_ExSet}, @{simproc Funcomp_Lambda}]))›


subsubsection ‹Reasoners›

φreasoner_ML assertion_simp_source 1300
  (‹Simplify (assertion_simps SOURCE) ?X' ?X›)
  = ‹Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Source.get' ctxt)) {fix_vars=false}) o snd›

φreasoner_ML assertion_simp_target 1300
  (‹Simplify (assertion_simps TARGET) ?X' ?X›)
  = ‹Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Target.get' ctxt)) {fix_vars=false}) o snd›

φreasoner_ML assertion_simp 1200
  (‹Premise (assertion_simps _) _› | ‹Simplify (assertion_simps ?ANY) ?X' ?X› )
  = ‹Phi_Reasoners.wrap (PLPR_Simplifier.simplifier_by_ss' (K Seq.empty) Assertion_SS.get' {fix_vars=false}) o snd›

ML ‹
fun conv_transformation_by_assertion_ss ctxt =
  let val src_ctxt = Assertion_SS_Source.enhance (Assertion_SS.equip ctxt)
      val target_ctxt = Assertion_SS_Target.enhance (Assertion_SS.equip ctxt)
   in Phi_Syntax.transformation_conv (Simplifier.rewrite src_ctxt)
                                     (Simplifier.rewrite target_ctxt)
                                     Conv.all_conv
  end

fun skolemize_transformation ctxt th =
  let fun skolem th =
       (case Phi_Syntax.dest_transformation (Thm.major_prem_of th)
          of (Const(\<^const_name>‹ExSet›, _) $ _,
              Const(\<^const_name>‹φTagA›, _) $ _ $ (Const(\<^const_name>‹REMAINS›, _) $ _ $ _ $ _), _) =>
              skolem (@{thm' skolemize_transformation_tR} RS th)
           | (Const(\<^const_name>‹ExSet›, _) $ _,
              Const(\<^const_name>‹REMAINS›, _) $ _ $ _ $ _, _) =>
              skolem (@{thm' skolemize_transformation_R} RS th)
           | (Const(\<^const_name>‹ExSet›, _) $ _, _, _) =>
              skolem (@{thm' skolemize_transformation} RS th)
           | _ => th)
   in th
   |> Conv.gconv_rule (Phi_Conv.hhf_concl_conv (fn ctxt =>
            conv_transformation_by_assertion_ss ctxt
          ) ctxt) 1
   |> skolem
  end
›


subsection ‹Transformation-based Simplification›

type_synonym forward_direction = bool (*false for backward*)

type_synonym substantial_change = bool (*For antecedent, be true to require simplification
                    changing something. For a reasoning rule, be true to represent the simplification
                    provided in the rule does make some substantial change.
                    It is used to prevent infinite loop of unchanging simplifications.*)

consts 𝒜simp' :: ‹ forward_direction ⇒ substantial_change ⇒ action ›
       𝒜_transitive_simp' :: ‹ forward_direction ⇒ substantial_change ⇒ action›
                  (*rules where simplifications will be applied
                    repeatedly on the simplified results given by the previous step.
                    The annotation exists only in the literal source syntacitcally but once
                    it is added to φ-LPR, will be reduced by a rule pass
                    converting ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜_transitive_simp› to
                    ‹Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z @tag 𝒜simp ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z @tag 𝒜simp›*)

abbreviation ‹𝒜simp ≡ 𝒜simp' True True›
abbreviation ‹𝒜_transitive_simp ≡ 𝒜_transitive_simp' True True›

abbreviation ‹𝒜backward_simp ≡ 𝒜simp' False True›
abbreviation ‹𝒜_backward_transitive_simp ≡ 𝒜_transitive_simp' False True›

text ‹Potentially weakening transformations designed for simplifying state sequents of the CoP.

  \<^prop>‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp›

  Doing this simplification in the framework of To-Transformation benefits it by reusing the
  To-Transformation support in transformation functors, which brings the simplification into the elements.

  The simplification is very heavy.
  For the sake of performance, it is indolent and is applied only when the state sequent
  needs the simplification. There is a mechanism to detect such need. The default strategy is,
  we collect all the registered simplification rules, get the pattern of the source type of the
  transformations, and if the types of a state sequent match any of a pattern, the simplification
  is required and activated.

  This default strategy is not perfect, so we provide hooks by which users can provide ML checkers.
  The checker can bind on either the whole types or subterms of specific constant heads.
  The checker only checks the type part.

  Note \<^prop>‹A @tag 𝒜simp› requires the process at least make one meaningful simplification
  step at least simplifies something, while \<^prop>‹A @tag 𝒜simp' direction False› allows returning with no-change.
  User can indicate to the system that his reasoning rule \<^prop>‹A @tag 𝒜simp' direction substantial_change› is
  meaningful by set ‹substantial_change ≡ True›, or ‹False› otherwise.
›

subsubsection ‹Convention›

φreasoner_group φsimp_all = (100, [1,4000]) for ( ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒜simp' direction substantial_change› )
      ‹Simplifying the assertion by means of transformation, which may weaken the assertion and
       refine the abstraction (or backwardly strengthen by ‹𝒜backward_simp›)›
 and φsimp_system_fallback = (1, [1,2]) in φsimp_all
      ‹System fallbacks of transformation-based simplification rule, which simplify nothing›
 and φsimp = (1000, [3, 4000]) in φsimp_all and > φsimp_system_fallback
      ‹User rules of transformation-based simplification›
 and φsimp_fallback = (10, [5,20]) in φsimp
      ‹Fallbacks of transformation-based simplification›
 and φsimp_derived = (50, [30,70]) in φsimp and > φsimp_fallback and < default
      ‹Automatically derived transformation-based simplification›
 and φsimp_cut = (1000, [1000, 1030]) in φsimp
      ‹Cutting rules of transformation-based simplification›

declare [[ φreason_default_pattern
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ _ 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜simp' True ?flag› ⇒
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp' True ?flag› (100)
  and ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ _ 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜_transitive_simp' True ?flag› ⇒
      ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_transitive_simp' True ?flag› (100)

  and ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜simp' False ?flag› ⇒
      ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp' False ?flag› (100)
  and ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 ?P @tag 𝒜_transitive_simp' False ?flag› ⇒
      ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?T y 𝗌𝗎𝖻𝗃 y. _) 𝗐𝗂𝗍𝗁 _ @tag 𝒜_transitive_simp' False ?flag› (100)

  and ‹?X @tag 𝒜simp' ?direction ?flag› ⇒
      ‹ERROR TEXT(‹Bad form: › (?X @tag 𝒜simp' ?direction ?flag) ⏎
                  ‹Expect: ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?Y 𝗌𝗎𝖻𝗃 y. ?r y) @tag 𝒜simp››)› (0)
  and ‹?X @tag 𝒜_transitive_simp' ?direction ?flag› ⇒
      ‹ERROR TEXT(‹Bad form: › (?X @tag 𝒜_transitive_simp' ?direction ?flag) ⏎
                  ‹Expect: ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ ?Y 𝗌𝗎𝖻𝗃 y. ?r y) @tag 𝒜simp››)› (0)
]]

subsubsection ‹Implementation›

consts 𝒜simp_if_need :: ‹forward_direction ⇒ substantial_change ⇒ action›
       𝒜transitive_simp_if_need :: ‹forward_direction ⇒ substantial_change ⇒ action›
       𝒜_apply_simplication :: ‹action›

lemma [φreason %cutting for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_apply_simplication›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y' 𝗐𝗂𝗍𝗁 Any @tag 𝒜_map_each_item (𝒜transitive_simp_if_need True False)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] Y : Y'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜_apply_simplication ›
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp

(*
lemma [φreason %cutting for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜_apply_simplication _›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Any @tag 𝒜_map_each_item (𝒜transitive_simp_if_need False)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 Y : Ya
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜_apply_simplication Any' ›
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp
*)

(*
lemma [φreason %φsimp]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp' M
⟹ ∀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 r y ⟶ (y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w y z @tag 𝒜transitive_simp_if_need False)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. (∃y. r y ∧ w y z) @tag 𝒜_transitive_simp' M ›
  unfolding Action_Tag_def Transformation_def Premise_def
  by clarsimp blast
*)

lemma 𝒜simp_invoke:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Any @tag 𝒜_map_each_item (𝒜transitive_simp_if_need True False)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y ›
  unfolding Action_Tag_def
  by (simp add: transformation_weaken)

lemma 𝒜simp_trans:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜_transitive_simp' direction Any
⟹ (⋀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 r y ⟹ y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w y z @tag 𝒜simp_if_need direction M)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. ∃y. r y ∧ w y z)
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜simp' direction Any2 ›
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp blast

lemma 𝒜simp_trans_backward:
  ‹ (⋀x. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 w x ⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r x y @tag 𝒜_transitive_simp' direction Any)
⟹ z ⦂ Z 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗌𝗎𝖻𝗃 x. w x @tag 𝒜simp_if_need direction M
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λy. ∃x. r x y ∧ w x)
⟹ z ⦂ Z 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r' y @tag 𝒜simp' direction Any2 ›
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp blast

lemma 𝒜simp_trans':
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. y = y' @tag 𝒜_transitive_simp' direction Any
⟹ y' ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w z @tag 𝒜simp_if_need direction M
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w z @tag 𝒜simp' direction Any2 ›
  unfolding Action_Tag_def Transformation_def
  by simp

lemma 𝒜simp_trans'P:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. y = y' ∧ P y @tag 𝒜_transitive_simp' direction Any
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P y' ⟹ y' ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w z @tag 𝒜simp_if_need direction M)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. w z ∧ P y')
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜simp' direction Any2 ›
  unfolding Action_Tag_def Transformation_def Simplify_def
  by simp

ML_file ‹library/tools/CoP_simp.ML›

context begin

private lemma 𝒜simp_chk_no_need:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒜simp_if_need direction Any›
  unfolding Action_Tag_def
  by simp

private lemma 𝒜simp_chk_no_need':
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T 𝗌𝗎𝖻𝗃 y. y = x @tag 𝒜simp_if_need direction Any›
  unfolding Action_Tag_def
  by (simp add: ExSet_defined)

private lemma 𝒜simp_chk_go:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜simp' direction M
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y @tag 𝒜simp_if_need direction M›
  unfolding Action_Tag_def .

private lemma 𝒜simp_chk_go_transitive:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp' direction M
⟹ ∀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 r y ⟶ (y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w y z @tag 𝒜transitive_simp_if_need direction False)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. ∃y. r y ∧ w y z)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜transitive_simp_if_need direction M›
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_go_transitive':
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp' direction M
⟹ ∀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 r y ⟶ (y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. w y z @tag 𝒜transitive_simp_if_need direction False)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. ∃y. r y ∧ w y z)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] Z' : z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z' @tag 𝒜transitive_simp_if_need direction M›
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_go_transitive_backward:
  ‹ (⋀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 w y ⟹ y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r y z @tag 𝒜simp' direction M)
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. w y @tag 𝒜transitive_simp_if_need direction False
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. ∃y. w y ∧ r y z)
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z @tag 𝒜transitive_simp_if_need direction M›
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_go_transitive_backward':
  ‹ (⋀y. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 w y ⟹ y ⦂ U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 z ⦂ Z 𝗌𝗎𝖻𝗃 z. r y z @tag 𝒜simp' direction M)
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. w y @tag 𝒜transitive_simp_if_need direction False
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r' : (λz. ∃y. w y ∧ r y z)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps SOURCE] Z' : z ⦂ Z 𝗌𝗎𝖻𝗃 z. r' z
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Z' @tag 𝒜transitive_simp_if_need direction M›
  unfolding Action_Tag_def Transformation_def Premise_def Simplify_def
  by clarsimp blast

private lemma 𝒜simp_chk_no_need_transitive:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒜transitive_simp_if_need direction Any›
  unfolding Action_Tag_def
  by simp

private lemma 𝒜simp_chk_no_need'_transitive:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T 𝗌𝗎𝖻𝗃 y. y = x @tag 𝒜transitive_simp_if_need direction Any›
  unfolding Action_Tag_def
  by (simp add: ExSet_defined)

φreasoner_ML 𝒜simp_if_need %cutting (‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp_if_need _ _›) = ‹
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val (bvs, goal) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (ToA, Const _ $ direction_term $ _) = PLPR_Syntax.dest_action_of' (K true) goal
      val (X, Y', _) = Phi_Syntax.dest_transformation ToA
      val direction = case direction_term of Const(\<^const_name>‹True›, _) => true
                                           | Const(\<^const_name>‹False›, _) => false
                                           | _ => raise TERM ("The direction of 𝒜simp_if_need must be a literal", [direction_term])
      val (Y, ex_bound) =
            case Y' of Const(\<^const_name>‹ExSet›, _) $ Abs (N, Ty,
                          Const(\<^const_name>‹Subjection›, _) $ (Y as Const(\<^const_name>‹φType›, _) $ Bound 0 $ _) $ _)
                         => (Y, SOME (N,Ty))
                     | _ => (Y', NONE)
   in if (if direction then Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt) bvs X
                       else Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) (the_list ex_bound @ bvs) Y)
   then SOME ((ctxt, @{thm' 𝒜simp_chk_go} RS' (ctxt, sequent)), Seq.empty)
   else let val rule = if is_some ex_bound then @{thm' 𝒜simp_chk_no_need'}
                                           else @{thm' 𝒜simp_chk_no_need}
    in SOME ((ctxt, rule RS' (ctxt, sequent)), Seq.empty)
   end
  end)
›

φreasoner_ML 𝒜transitive_simp_if_need %cutting (‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜transitive_simp_if_need _ _›) = ‹
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val (bvs, goal) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (ToA, Const _ $ direction_term $ _) = PLPR_Syntax.dest_action_of' (K true) goal
      val (X, Y', _) = Phi_Syntax.dest_transformation ToA
      val direction = case direction_term of Const(\<^const_name>‹True›, _) => true
                                           | Const(\<^const_name>‹False›, _) => false
                                           | _ => raise TERM ("The direction of 𝒜simp_if_need must be a literal", [direction_term])
      val (Y, ex_bound) =
            case Y' of Const(\<^const_name>‹ExSet›, _) $ Abs (N, Ty,
                          Const(\<^const_name>‹Subjection›, _) $ (Y as Const(\<^const_name>‹φType›, _) $ Bound 0 $ _) $ _)
                         => (Y, SOME (N, Ty))
                     | _ => (Y', NONE)
   in if (if direction then Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt) bvs X
                       else Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) (the_list ex_bound @ bvs) Y)
   then SOME ((ctxt, (if direction then if is_some ex_bound
                                        then @{thm' 𝒜simp_chk_go_transitive}
                                        else @{thm' 𝒜simp_chk_go_transitive'}
                                   else if is_some ex_bound
                                        then @{thm' 𝒜simp_chk_go_transitive_backward}
                                        else @{thm' 𝒜simp_chk_go_transitive_backward'})
                      RS' (ctxt, sequent)), Seq.empty)
   else let val rule = if is_some ex_bound then @{thm' 𝒜simp_chk_no_need'_transitive}
                                           else @{thm' 𝒜simp_chk_no_need_transitive}
    in SOME ((ctxt, rule RS' (ctxt, sequent)), Seq.empty)
   end
  end)
›

end

 
lemma [φreason default ! %φsimp_system_fallback+1
               for ‹_ ⦂ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ _ 𝗌𝗎𝖻𝗃 y. _ @tag 𝒜simp' _ False›]:
  ‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T 𝗌𝗎𝖻𝗃 y. y = x @tag 𝒜simp' direction False›
  unfolding Action_Tag_def
  by (simp add: ExSet_defined)

lemma [φreason default ! %φsimp_system_fallback
               for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒜simp' _ False›]:
  ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X @tag 𝒜simp' direction False›
  unfolding Action_Tag_def
  by simp


(*declare [[φsimp_rule_pass]] ― ‹Must be enabled until all the internal rules are registered as
      it modifies any rule in form ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y› into ‹Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?? ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ??››
*)
(* TODO
hide_fact 𝒜simp_stage_1 𝒜simp_chk_no_need 𝒜simp_chk_no_need'
          𝒜simp_chk_go 𝒜simp_trans 𝒜simp_trans' 𝒜simp_trans'P
*)

paragraph ‹Invoking CoP-simp in ToA reasoning›



ML ‹

val normalize_source = @{lemma
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X' @tag 𝒜_map_each_item (𝒜transitive_simp_if_need True False)
⟹ X' 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by (clarsimp simp: Action_Tag_def Transformation_def, blast)
}

fun normalize_source_of_ToA (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (X, _, _) = Phi_Syntax.dest_transformation ToA
   in if Phi_Syntax.exists_item_of_assertion (Phi_CoP_Simp.is_simp_needed (Context.Proof ctxt)) bvs X
      then (
        Phi_Reasoner.info_print ctxt 2 (K "normalizing the source assertion of the transformation") ;
        case Phi_Reasoner.internal_reason NONE (SOME 1) (ctxt, normalize_source RS sequent)
          of NONE => (ctxt, sequent)
           | SOME (ctxt', sequent') => 
                (ctxt', Conv.gconv_rule (Phi_Conv.hhf_concl_conv (conv_transformation_by_assertion_ss) ctxt') 1 sequent'))
      else (ctxt, sequent)
  end

fun normalize_target_of_ToA parse (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val (Y, rule) = parse (Phi_Syntax.dest_transformation ToA)
                      (* of (_, Const(\<^const_name>‹REMAINS›, _) $ Y $ _ $ _, _) => (Y, true)
                          | (_, Y, _) => (Y, false) *)
   in if Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) bvs Y
      then (
        Phi_Reasoner.info_print ctxt 2 (K "normalizing the target assertion of the transformation") ;
        case Phi_Reasoner.internal_reason NONE (SOME 1) (ctxt, rule RS sequent)
          of NONE => (ctxt, sequent)
           | SOME ret => ret)
      else (ctxt, sequent)
  end

fun chk_target_of_ToA_requires_normalization parse_term (ctxt, sequent) =
  let val (bvs, ToA) = Phi_Help.strip_meta_hhf_bvs (Phi_Help.leading_antecedent' sequent)
      val target = parse_term (#2 (Phi_Syntax.dest_transformation ToA))
   in Phi_CoP_Backward_Simp.is_simp_needed (Context.Proof ctxt) bvs target orelse
      (case target
         of Const(\<^const_name>‹φType›, _) $ x $ T =>
              let val head = Term.head_of x
               in not (is_Var head) orelse exists_subterm (fn y => y aconv head) T
              end
          | _ => false)
  end
›



subsubsection ‹Simplification Protect›

definition [simplification_protect]:
  ‹φTBS_Simp_Protect X U r direction flag ≡ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜simp' direction flag›

lemma [cong]:
  ‹ X ≡ X'
⟹ U ≡ U'
⟹ r ≡ r'
⟹ φTBS_Simp_Protect X U r direction flag ≡ φTBS_Simp_Protect X' U' r' direction flag ›
  by simp

subsubsection ‹Extracting Pure›

lemma [φreason %extract_pure]:
  ‹ 𝗋ESC P A
⟹ 𝗋ESC P (A @tag 𝒜simp' direction any) ›
  unfolding Action_Tag_def
  by blast

lemma [φreason %extract_pure]:
  ‹ 𝗋EIF A P
⟹ 𝗋EIF (A @tag 𝒜simp' direction any) P ›
  unfolding Action_Tag_def
  by blast


subsection ‹Falling Lattice of Transformation Sub-procedures›

(*
lemma [φreason default %ToA_falling_latice-1]:
  ‹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def by blast
*)

subsubsection ‹From ‹𝒯𝒫'› to ‹𝒯𝒫››

lemma [φreason default %ToA_falling_latice+3]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 fst x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ May_Assign (snd x) unspec
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y, unspec) ⦂ U ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫' ›
  unfolding 𝗋Guard_def Action_Tag_def
  by simp

lemma [φreason default %ToA_falling_latice+2]:
  ‹ x ⦂ X ∗[True] Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 prod.swap x ⦂ Y ∗[True] X @tag 𝒯𝒫' ›
  for X :: ‹('a::sep_ab_semigroup,'b) φ›
  unfolding Action_Tag_def Cond_φProd_def φProd_def φType_def Transformation_def
  by (cases x; simp add: mult.commute)

lemma [φreason default %ToA_falling_latice+1]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 Push_Envir_Var prove_obligations_in_time True ∧⇩𝗋
         Identity_Element⇩I (fst x ⦂ T) P ∧⇩𝗋
         Pop_Envir_Var prove_obligations_in_time
⟹ x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, unspec) ⦂ U ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  ― ‹the transformation from T to U fails, and the algebra is non-commutative, nor any methods of a higher priority,
      so ‹T› or ‹U› can only be identity if the reasoning can continue›
  unfolding 𝗋Guard_def Ant_Seq_def Identity_Element⇩I_def Transformation_def Action_Tag_def
  by (clarsimp; fastforce)

lemma [φreason default %ToA_falling_latice]:
  ‹ Identity_Element⇩E (one ⦂ U)
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (one, fst x) ⦂ U ∗[True] T @tag 𝒯𝒫'›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding 𝗋Guard_def Ant_Seq_def Identity_Element⇩E_def Transformation_def Premise_def Action_Tag_def
  by (clarsimp; force)

(*
lemma [φreason default %ToA_falling_latice+2]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 Push_Envir_Var prove_obligations_in_time True ∧⇩𝗋
         Identity_Element⇩I (fst x ⦂ T) P ∧⇩𝗋
         Pop_Envir_Var prove_obligations_in_time
⟹ x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (snd x, unspec) ⦂ U ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁 P›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding 𝗋Guard_def Ant_Seq_def Identity_Element⇩I_def Transformation_def
  by (clarsimp; fastforce)

lemma [φreason default %ToA_falling_latice+1]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 Push_Envir_Var prove_obligations_in_time True ∧⇩𝗋
         Identity_Element⇩E (one ⦂ U) ∧⇩𝗋
         Pop_Envir_Var prove_obligations_in_time ∧⇩𝗋
         (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[MODE_SAT] y = (one, fst x))
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[True] T›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding 𝗋Guard_def Ant_Seq_def Identity_Element⇩E_def Transformation_def Premise_def
  by (clarsimp; force)
*)

(*
declare [[φreason default %ToA_falling_latice + 1
          ToA_falling_lattice_SE_1 ToA_falling_lattice_SE_2
          for ‹_ ⦂ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _›]]*)

subsubsection ‹From ‹𝒯𝒫› to ‹𝒯𝒫'››

paragraph ‹Preliminary›

φreasoner_group SE_internal = (1000, [1000, 2000]) ‹internal›
        and SE_internal_err = (10, [10, 10]) < SE_internal ‹internal›

subparagraph ‹Unital›

definition ‹SE_tail1 Cw Cr A P1 r R     w W R3 P
  ⟷ (if Cw then (∃P2 RR. (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P2)
                          ∧ R3 = (if Cr then (r ⦂ R) * RR else RR)
                          ∧ P = (P2 ∧ P1))
             else P = P1 ∧ R3 = (if Cr then (r ⦂ R) * A else A))›

declare [[
  φreason_default_pattern ‹SE_tail1 ?Cw ?Cr ?A ?P1 ?r ?R _ _ _ _›
                       ⇒ ‹SE_tail1 ?Cw ?Cr ?A ?P1 ?r ?R _ _ _ _›   (100)
]]

lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ SE_tail1 True True A P1 r R   w W ((r ⦂ R) * RR) (P2 ∧ P1) ›
  unfolding SE_tail1_def Action_Tag_def
  by (simp, rule exI[where x=P2], rule exI[where x=RR], simp)

lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 RR 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ SE_tail1 True False A P1 r R   w W RR (P2 ∧ P1) ›
  unfolding SE_tail1_def Action_Tag_def
  by (simp, rule exI[where x=P2], simp)

lemma [φreason %SE_internal]:
  ‹ SE_tail1 False True A P1 r R   w W ((r ⦂ R) * A) P1 ›
  unfolding SE_tail1_def Action_Tag_def
  by simp

lemma [φreason %SE_internal]:
  ‹ SE_tail1 False False A P1 r R   w W A P1 ›
  unfolding SE_tail1_def Action_Tag_def
  by simp

lemma [φreason %SE_internal_err]:
  ‹ ERROR TEXT(‹ToA: condition variables are not literal› (Cw, Cr))
⟹ SE_tail1 Cw Cr A P1 r R   w W A P1 ›
  unfolding ERROR_def Action_Tag_def
  by simp

subparagraph ‹Non-Unital›

definition ‹SE_tail Cw Cr A P1 r R
                    w W C R3 P
  ⟷ (∃P2 RR Crr.
          (if Cw then (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Crr] RR 𝗐𝗂𝗍𝗁 P2) else (P2, Crr) = (True, False)) ∧
          C = (Cr ∨ Crr ∨ ¬ Cw) ∧
          (if Crr then if Cr then R3 = (r ⦂ R) * RR else R3 = RR
           else if Cw then if Cr then R3 = (r ⦂ R) else True
           else if Cr then R3 = (r ⦂ R) * A else R3 = A) ∧
          P = (P2 ∧ P1)) ›

declare [[
  φreason_default_pattern ‹SE_tail ?Cw ?Cr ?A ?P1 ?r ?R _ _ _ _ _›
                       ⇒ ‹SE_tail ?Cw ?Cr ?A ?P1 ?r ?R _ _ _ _ _›   (100)
]]


lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Crr] RR 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ ◒⇩B⇩I[True] R3 = ◒⇩B⇩I[True] (r ⦂ R) * ◒⇩B⇩I[Crr] RR @tag 𝒜merge
⟹ SE_tail True True A P1 r R   w W True R3 (P2 ∧ P1) ›
  unfolding SE_tail_def Action_Tag_def
  by (rule exI[where x=P2]; rule exI[where x=RR]; rule exI[where x=Crr];
      cases Crr; clarsimp simp: φCond_Unital_BI_Prod φCond_Unital_BI_eq_strip)

lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Crr] RR 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ ◒⇩B⇩I[Crr] R3 = ◒⇩B⇩I[False] ⊤ * ◒⇩B⇩I[Crr] RR @tag 𝒜merge
⟹ SE_tail True False A P1 r R   w W Crr R3 (P2 ∧ P1) ›
  unfolding SE_tail_def Action_Tag_def
  by (rule exI[where x=P2]; rule exI[where x=RR]; rule exI[where x=Crr];
      cases Crr; clarsimp simp: φCond_Unital_BI_Prod φCond_Unital_BI_eq_strip)

lemma [φreason %SE_internal]:
  ‹ SE_tail False True A P1 r R   w W True ((r ⦂ R) * A) P1 ›
  unfolding SE_tail_def
  by (rule exI[where x=True]; rule; rule exI[where x=False]; clarsimp)

lemma [φreason %SE_internal]:
  ‹ SE_tail False False A P1 r R   w W True A P1 ›
  unfolding SE_tail_def
  by (rule exI[where x=True]; rule; rule exI[where x=False]; clarsimp)

lemma [φreason %SE_internal_err]:
  ‹ ERROR TEXT(‹ToA: condition variables are not literal› (Cw, Cr))
⟹ SE_tail Cw Cr A P1 r R   w W True A P1 ›
  unfolding ERROR_def
  by simp

paragraph ‹Boundary›

definition ‹SE_tail_Rw C⇩W A w W P2
  ⟷ (if C⇩W then A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2 else Identity_Element⇩I A P2) ›

declare [[
  φreason_default_pattern ‹SE_tail_Rw ?C⇩W ?A _ _ _› ⇒ ‹SE_tail_Rw ?C⇩W ?A _ _ _› (100)
]]

lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ SE_tail_Rw True A w W P2 ›
  unfolding SE_tail_Rw_def Action_Tag_def
  by simp

lemma [φreason %SE_internal]:
  ‹ Identity_Element⇩I A P2
⟹ SE_tail_Rw False A w W P2 ›
  unfolding SE_tail_Rw_def
  by simp

lemma [φreason %SE_internal_err]:
  ‹ ERROR TEXT(‹ToA: condition variables are not literal› Cw)
⟹ SE_tail_Rw Cw A w W P2 ›
  unfolding ERROR_def
  by simp

(*
paragraph ‹Single Target›


lemma [φreason default %ToA_falling_latice]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ if C⇩R then Identity_Element⇩I R Q else Q = True
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P ∧ Q @tag 𝒯𝒫 ›
  for X :: ‹'a :: sep_magma_1 set›
  unfolding Action_Tag_def φProd_expn' Identity_Element⇩I_def Premise_def
            Transformation_def Try_def Ant_Seq_def
  by (cases C⇩R; clarsimp; fastforce)
*)

paragraph ‹Rules›

lemma [φreason default %ToA_falling_latice+3]:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr ⦂ U ∗[C] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ if C⇩W then Identity_Element⇩E (w ⦂ W) else True
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst yr ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] snd yr ⦂ R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  for T :: ‹('c::sep_magma_1, 'x) φ›
  unfolding Premise_def Identity_Element⇩E_def Try_def Action_Tag_def
  apply (cases C; cases C⇩W; clarsimp simp add: φSome_transformation_strip φProd_expn'' φProd_expn')
  apply (metis mk_elim_transformation mult_1_class.mult_1_right transformation_left_frame)
  by (metis mk_elim_transformation mult_1_class.mult_1_right transformation_left_frame)

lemma [φreason default %ToA_falling_latice+3]:
  ‹ (x,w) ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y' : y
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y⇩1 : fst y'
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] r  : snd y'
⟹ SE_tail1 Cw Cr A P1 r R     w W R3 P
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩1 ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R3 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  for A :: ‹'a::sep_monoid BI›
  unfolding SE_tail1_def Action_Tag_def Simplify_def Action_Tag_def
  by ((cases Cw; cases Cr;
       clarsimp simp: φSome_φProd φSome_transformation_strip φProd_expn' φProd_expn'' mult.assoc[symmetric]),
       metis mult.assoc transformation_left_frame transformation_right_frame transformation_trans,
       metis (no_types, opaque_lifting) mult.assoc transformation_left_frame transformation_right_frame transformation_trans,
       insert transformation_right_frame, blast, blast)

lemma [φreason default %ToA_falling_latice+3]:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ if C⇩R then Identity_Element⇩I (snd y ⦂ R) Q else Q = True
⟹ SE_tail_Rw C⇩W A w W P2
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗐𝗂𝗍𝗁 P2 ∧ Q ∧ P1 @tag 𝒯𝒫 ›
  for A :: ‹'a :: sep_magma_1 set›
  unfolding Action_Tag_def φProd_expn' Identity_Element⇩I_def Premise_def
            Transformation_def Try_def Ant_Seq_def SE_tail_Rw_def
  by (cases C⇩W; cases C⇩R; clarsimp; fastforce)




lemma [φreason default %ToA_falling_latice+2 except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yr ⦂ U ∗[C] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C⇩W
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst yr ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] snd yr ⦂ R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Premise_def Try_def Action_Tag_def
  by (cases C; clarsimp simp add: φSome_transformation_strip φProd_expn'')


lemma [φreason default %ToA_falling_latice+2 except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (x,w) ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y' : y
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y⇩1 : fst y'
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] y⇩2 : snd y'
⟹ SE_tail Cw Cr A P1 y⇩2 R   w W C R3 P
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩1 ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R3 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  for A :: ‹'a::sep_semigroup BI›
  unfolding Action_Tag_def REMAINS_def Simplify_def Try_def SE_tail_def Simplify_def
  apply clarify
  apply (cases Cw; cases Cr; case_tac Crr; cases y;
         simp add: φSome_φProd φSome_transformation_strip φProd_expn')

  subgoal premises prems for P2 RR Crr a b
    by (insert prems(5)[THEN transformation_right_frame, where R=‹x ⦂ T›]
               prems(1)[THEN transformation_left_frame, where R=RR],
        simp add: mult.assoc transformation_trans,
        smt (verit, ccfv_threshold) Transformation_def mult.assoc prems(1) prems(5) transformation_left_frame transformation_right_frame)
  using transformation_left_frame transformation_trans apply blast

  subgoal premises prems for P2 RR Crr a b
    by (insert prems(5)[THEN transformation_right_frame, where R=‹x ⦂ T›]
               prems(1)[THEN transformation_left_frame, where R=RR],
        simp add: mult.assoc transformation_trans,
        metis (no_types, opaque_lifting) mult.assoc prems(1) prems(5) transformation_left_frame transformation_right_frame transformation_trans)
  using transformation_left_frame transformation_trans apply blast
  apply (metis mult.assoc transformation_right_frame)
  using transformation_right_frame by blast

lemma [φreason default %ToA_falling_latice+2 except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[𝗌𝖺𝖿𝖾] (¬ C⇩R ∧ C⇩W)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗐𝗂𝗍𝗁 P2 ∧ P1 @tag 𝒯𝒫 ›
  for A :: ‹'a :: sep_magma set›
  unfolding Action_Tag_def φProd_expn' Identity_Element⇩I_def Premise_def
            Transformation_def Try_def Identity_Element⇩E_def Ant_Seq_def
  by (cases C⇩W; cases C⇩R; clarsimp; blast)






lemma [φreason default %ToA_falling_latice+1]: ― ‹when X fails to match ‹x ⦂ T››
  ‹ R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ ◒⇩B⇩I[True] R'' = ◒⇩B⇩I[True] X * ◒⇩B⇩I[C⇩R] R' @tag 𝒜merge
⟹ X * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R'' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  for Y :: ‹'c::sep_ab_semigroup BI›
  unfolding Action_Tag_def
  by ((cases C⇩R; clarsimp),
      smt (verit) φCond_Unital_BI_Prod φCond_Unital_BI_eq_strip mult.assoc mult.commute transformation_right_frame,
      metis φCond_Unital_BI_eq_strip mult.commute transformation_right_frame)

lemma [φreason default %ToA_falling_latice]: ― ‹when X fails to match ‹x ⦂ T›, nor a abelian semigroup›
  ‹ Identity_Element⇩E (var_y ⦂ U)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 var_y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 X @tag 𝒯𝒫 ›
  for X :: ‹'c::sep_magma_1 BI›
  unfolding Transformation_def Identity_Element⇩E_def Action_Tag_def
  by (clarsimp, force)


(*
lemma [φreason %ToA_red for ‹_ ⦂ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                         except ‹_ ⦂ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
      ― ‹\<^prop>‹x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R› is invalid when ‹T ≠ (_ ∗[_] _)›. The rule corrects
          such mistake eagerly (though may affect the overall performance).›
  ‹ (x, unspec) ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ Cw
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Premise_def Action_Tag_def
  by simp
*)


hide_const (open) SE_tail1 SE_tail

subsection ‹Essential Reasoning Procedures›

subsubsection ‹Reflexive Transformation›

paragraph ‹When the target and the source are either alpha-equivalent or unified›

text ‹Applying reflexive transformation on alpha-equivalent couples of source and target is safe,
so be applied of high priority.
In contrast, unification by reflexive transformation is aggressive. Therefore, they are applied
only when no other rules are applicable.›

(*TODO: Auto_Transform_Hint*)

declare transformation_refl [φreason %ToA_refl for ‹?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                                   ‹_ ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?T 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›,
                             φreason %ToA_unified_refl for ‹_ ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?U 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]

lemma [φreason default %ToA_unified_refl for ‹?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A' 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A ›
  unfolding Premise_def 𝗋Guard_def Action_Tag_def
  by simp

lemma [φreason %ToA_refl for ‹?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (?A :: ?'c::sep_magma_1 BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›,
       φreason default %ToA_unified_refl for ‹?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (?A' :: ?'c::sep_magma_1 BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ Identity_Element⇩I R P
⟹ A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P ›
  for A :: ‹'c::sep_magma_1 BI›
  unfolding Identity_Element⇩I_def Transformation_def Action_Tag_def
  by clarsimp fastforce

lemma transformation_refl_assigning_remainder [φreason %ToA_assigning_var for ‹?A * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›
                                                                ‹(_ ⦂ ?T) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R›
  unfolding REMAINS_def Action_Tag_def
  by simp

lemma [φreason default %ToA_unified_refl for ‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ A * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R›
  unfolding Premise_def REMAINS_def 𝗋Guard_def Action_Tag_def
  by simp


lemma transformation_refl_with_remainder [φreason %ToA_assigning_var for ‹?A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                                           ‹_ ⦂ ?T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y ⦂ ?T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] ⊤›
  unfolding Action_Tag_def
  by simp

lemma [φreason default %ToA_unified_refl for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] ⊤›
  unfolding Premise_def 𝗋Guard_def Action_Tag_def
  by simp

lemma transformation_refl_assigning_W [φreason %ToA_assigning_var]:
  ‹x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x, unspec) ⦂ (T ∗ U) ∗[False] ⊤⇩φ›
  unfolding Action_Tag_def
  by simp

lemma [φreason default %ToA_unified_refl for ‹_ ⦂ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗ _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ x ⦂ T ∗[True] U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x, unspec) ⦂ (T ∗ U) ∗[False] ⊤⇩φ ›
  unfolding Premise_def 𝗋Guard_def Action_Tag_def
  by simp

lemma transformation_refl_assigning_R [φreason %ToA_assigning_var]:
  ‹ May_Assign (snd x) unspec
⟹ x ⦂ (T ∗ U) ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst x ⦂ T ∗[True] U ›
  unfolding Action_Tag_def
  by simp

lemma [φreason default %ToA_unified_refl for ‹_ ⦂ (_ ∗ _) ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ ― ‹𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 T = T' ⟹›
    May_Assign (snd x) unspec
⟹ x ⦂ (T ∗ U) ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst x ⦂ T ∗[True] U ›
  unfolding Premise_def 𝗋Guard_def Action_Tag_def
  by simp

lemma transformation_refl_with_WR [φreason %ToA_assigning_var+1]:
        ― ‹Higher than ‹transformation_refl› to set the condition variable Cr›
  ‹ May_Assign (snd x) unspec
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T ∗[False] ⊤⇩φ ›
  unfolding Action_Tag_def
  by simp

lemma [φreason default %ToA_unified_refl+1 for ‹_ ⦂ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ ― ‹𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 T = T' ⟹›
    May_Assign (snd x) unspec
⟹ x ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T ∗[False] ⊤⇩φ›
  unfolding Action_Tag_def
  by simp


lemma ToA_refls_by_T_eq:
  ‹ T = T'
⟹ May_Assign (snd x⇩2) unspec
⟹ x⇩2 ⦂ T ∗[False] ⊤⇩φ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x⇩2 ⦂ T' ∗[False] ⊤⇩φ ›
  ‹ T = T'
⟹ (x ⦂ T) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T' 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R ›
  ‹ T = T'
⟹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T' ›
  by simp_all


paragraph ‹When the target is a schematic variable›

text ‹Schematic variables occurring in source are assigned with zeros, and is
  covered by §‹Phi_BI/Bottom/Transformation_Rules››

ML ‹
(* (⋀x. X x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 P) where ?Y is a variable.
   When X contains some quantified variables ‹x› that do not parameterize ?Y, the procedure
   existentially qualifies X, and assign ‹∃x. X x› to ?Y.
   cannot work on ‹_ ∗[_] _› (*TODO, but the thing is there is no type embedding of existence,
                                     unless we use Σ and 𝒮, but... mmmmm.... well, a lot of work.*)
 *)
fun apply_refl_by_unifying (refl, exintro', Gx, Gy) ctxt thm =
  let val (vs, _, goal) = Phi_Help.leading_antecedent (Thm.prop_of thm)
      val N = length vs
      val (X0,Y0,_) = Phi_Syntax.dest_transformation goal
      val (X, Y) = (Gx X0, Gy Y0)
      val (Var V, args) = strip_comb Y
      val bnos = map_filter (fn Bound i => SOME i | _ => NONE) args
      val bads = subtract (op =) bnos (Term.loose_bnos X)
   in if null bads
   then Phi_Reasoner.single_RS refl ctxt thm
   else case exintro'
     of NONE => Seq.empty
      | SOME exintro => let
      val N_bads = length bads
      val N_bnos = length bnos
      val (argTys, \<^Type>‹set ‹TY››) = Term.strip_type (snd V)
      val insts' = List.tabulate (N, fn i =>
            let val bi = find_index (fn k => k = i) bads
                val ci = find_index (fn k => k = i) bnos
             in if bi <> ~1
                then Bound (N_bads - 1 - bi)
                else if ci <> ~1
                then Bound (N_bads + N_bnos - 1 - ci)
                else Term.dummy (*not occur*)
            end)
      val Y'1 = subst_bounds (insts', X)
      val Y'2 = fold_rev (fn j => fn TM =>
                  let val (name,T) = List.nth (vs, N-1-j)
                   in \<^Const>‹ExSet ‹T› ‹TY›› $ Abs (name, T, TM)
                  end) bads Y'1
      val Y'3 = fold_rev (fn (_, Bound j) => (fn TM =>
                            let val (name,T) = List.nth (vs, N-1-j)
                             in Abs (name, T, TM)
                            end)
                       | (ty, _) => (fn TM => Abs ("_", ty, TM))
                     ) (argTys ~~ args) Y'2
   in Thm.instantiate (TVars.empty, Vars.make [(V, Thm.cterm_of ctxt Y'3)]) thm
   |> funpow N_bads (fn th => exintro RS th)
   |> Phi_Reasoner.single_RS refl ctxt
   handle THM _ => Seq.empty
  end
  end
›

φreasoner_ML transformation_refl_var %ToA_assigning_var (‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›) = ‹
  fn (_, (ctxt,thm)) => Seq.map (pair ctxt) (apply_refl_by_unifying (
          @{thm' transformation_refl[THEN Action_Tag_I[where A=𝒯𝒫]]},
          SOME @{thm' ExSet_transformation_I[THEN Action_Tag_I[where A=𝒯𝒫], OF Action_Tag_D[where A=𝒯𝒫]]},
          I, I
      ) ctxt thm) ›

φreasoner_ML transformation_refl_var_R %ToA_assigning_var (‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›) = ‹
  fn (_, (ctxt,thm)) => Seq.map (pair ctxt) (apply_refl_by_unifying (
          @{thm' transformation_refl_assigning_remainder[THEN Action_Tag_I[where A=𝒯𝒫]]},
          SOME @{thm' ExSet_transformation_I_R[THEN Action_Tag_I[where A=𝒯𝒫], OF Action_Tag_D[where A=𝒯𝒫]]},
          (fn _ $ A $ R => A), (fn _ (*REMAINS*) $ A $ _ $ _ => A)
      ) ctxt thm) ›

φreasoner_ML transformation_refl_var_R' %ToA_assigning_var+1 (‹_ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›) = ‹
  fn (_, (ctxt,thm)) => Seq.map (pair ctxt) (apply_refl_by_unifying (
          @{thm' transformation_refl_with_remainder[THEN Action_Tag_I[where A=𝒯𝒫]]},
          SOME @{thm' ExSet_transformation_I_R[THEN Action_Tag_I[where A=𝒯𝒫], OF Action_Tag_D[where A=𝒯𝒫]]},
          I, (fn _ (*REMAINS*) $ A $ _ $ _ => A)
      ) ctxt thm) ›


text ‹Here, we assign the semantics of schematic variables occurring in targets and sources to be,
  a wild-card for any single separation item.›

declare transformation_refl_assigning_W [φreason %ToA_assigning_var for ‹_ ⦂ ?var ∗[True] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗ _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]
        transformation_refl_assigning_R [φreason %ToA_assigning_var for ‹_ ⦂ (_ ∗ _) ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?var ∗[True] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]
        transformation_refl_with_WR [φreason %ToA_assigning_var+1 for ‹_ ⦂ ?var ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
                                                                      ‹_ ⦂ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?var ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]
(*
lemma [φreason 4100 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ ?var_U ∗[_] _ 𝗐𝗂𝗍𝗁 _›
                        ‹_ ⦂ ?var_T ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _›
                    except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[False] _ 𝗐𝗂𝗍𝗁 _›
                           ‹_ ⦂ _ ∗[False] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _› ]:
  ‹ ERROR TEXT(‹Unable to reason the transformation where the target (or the source) has more than one variable assertions›
               (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P)
               ‹It usually means somewhere in the reasoning system is wrong›)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P ›
  unfolding ERROR_def
  by blast
*)

text ‹
TODO: move me!

NToA procedure addresses the transformation between any-to-many φ-type items.
  Separation Extraction addresses that from many to one φ-type item.
  The φ-type themselves should provide the rules for one-to-one transformations, as they are primitive.
  Transformation Functor presented later provides an automation for this.

  However, a small supplementary is one-to-one with remainders.
  For unital algebras, the issue is easy as we can always force yielding remainders.
  For non-semigroups, after a reasoning branch splitting the cases for having remainder or not,
  the issue reduces immediately.
  For associative but non-unital algebras, a bit of work is required. 

›

subsubsection ‹Varify Target Object›

lemma [φreason default %ToA_varify_target_object for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫 ›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
  by clarsimp metis

lemma [φreason default %ToA_varify_target_object for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                              except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var_y' ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _  @tag 𝒯𝒫›]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
  by (cases C; clarsimp; metis)


subsubsection ‹Basic Transformation Rules›

paragraph ‹Plainize›

lemma [φreason %ToA_normalizing]:
  " T1 * (T2 * R) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ (T1 * T2) * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P"
  for R :: ‹'a::sep_semigroup BI›
  unfolding mult.assoc .

lemma [φreason %ToA_normalizing]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X1 * (X2 * R) 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X1 * X2) * R 𝗐𝗂𝗍𝗁 P"
  for R :: ‹'a::sep_semigroup BI›
  unfolding mult.assoc .

lemma [φreason %ToA_normalizing]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X1 * (X2 * X3) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X1 * X2) * X3 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  for R :: ‹'a::sep_semigroup BI›
  unfolding mult.assoc .


paragraph ‹Splitting Separation Assertion in Target›

definition ‹SP_TGT C X Y C⇩R R P (tag::bool) ⟷
   (if C then (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P)
         else Identity_Element⇩E Y ∧ (P,C⇩R,R) = (True, False, ⊤)) ›

φreasoner_group SP_TGT = (1010, [1000, 1030]) ‹›

lemma [φreason %SP_TGT for ‹SP_TGT True _ _ _ _ _ True›
                           ‹SP_TGT ?var _ _ _ _ _ True›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ SP_TGT True X Y C⇩R R P True ›
  unfolding SP_TGT_def Action_Tag_def
  by simp

lemma [φreason %SP_TGT for ‹SP_TGT True _ _ _ _ _ False›
                           ‹SP_TGT ?var _ _ _ _ _ False›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ SP_TGT True X Y C⇩R R P False ›
  unfolding SP_TGT_def Action_Tag_def
  by simp

lemma [φreason %SP_TGT+10 for ‹SP_TGT True _ _ False ⊤ _ True›
                              ‹SP_TGT ?var _ _ False ⊤ _ True›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ SP_TGT True X Y False ⊤ P True ›
  unfolding SP_TGT_def Action_Tag_def
  by simp

lemma [φreason %SP_TGT+10 for ‹SP_TGT True _ _ False ⊤ _ False›
                              ‹SP_TGT ?var _ _ False ⊤ _ False›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ SP_TGT True X Y False ⊤ P False ›
  unfolding SP_TGT_def Action_Tag_def
  by simp

lemma [φreason %SP_TGT for ‹SP_TGT False _ _ _ _ _ _› ]:
  ‹ Identity_Element⇩E Y
⟹ SP_TGT False X Y False ⊤ True Any›
  unfolding SP_TGT_def
  by simp

lemma [φreason %SP_TGT-10 for ‹SP_TGT _ _ _ _ _ _ _›]:
  ‹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[mode_literal] C' : C
⟹ SP_TGT C' X Y C⇩R R P Any
⟹ SP_TGT C  X Y C⇩R R P Any ›
  unfolding SP_TGT_def Simplify_def
  by simp



lemma [φreason %ToA_splitting_target except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C⇩R
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫"
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
  by (cases C⇩R; clarsimp; force)

lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (SP_TGT C⇩R R Y False ⊤ P2 True)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫 "
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
            Identity_Element⇩E_def Ant_Seq_def SP_TGT_def
  by (cases C⇩R; clarsimp; force)

(*
lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P1
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (if C⇩R then (R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P2)
                           else Identity_Element⇩E Y ∧⇩𝗋 P2 = True)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * X 𝗐𝗂𝗍𝗁 P1 ∧ P2"
  for A :: ‹'a::sep_magma_1 BI›
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
            Identity_Element⇩E_def Ant_Seq_def
  by (cases C⇩R; clarsimp; force)
*)


lemma [φreason %ToA_splitting_target except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R1 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C⇩R
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (R1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫 "
  for A :: ‹'a::sep_semigroup BI›
  unfolding Action_Tag_def REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
  by (cases C; clarsimp; metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc)


lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R1 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ SP_TGT C⇩R R1 Y C R' P2 True
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫 "
  for A :: ‹'a::{sep_semigroup, sep_magma_1} BI›
  unfolding REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
            Identity_Element⇩E_def Ant_Seq_def SP_TGT_def
  by ((cases C; cases C⇩R; clarsimp),
      metis sep_disj_multD1 sep_disj_multI1 sep_mult_assoc',
      blast,
      metis mult_1_class.mult_1_right sep_magma_1_left)

(*
lemma [φreason %ToA_splitting_target]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R1 𝗐𝗂𝗍𝗁 P1
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟹ if C⇩R then (R1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P2)
                          else Identity_Element⇩E Y ∧⇩𝗋 (P2, C, R') = (True, False, ⊤))
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P1 ∧ P2"
  for A :: ‹'a::{sep_semigroup, sep_magma_1} BI›
  unfolding REMAINS_def Transformation_def split_paired_All Action_Tag_def Premise_def
            Identity_Element⇩E_def Ant_Seq_def
  by ((cases C; cases C⇩R; clarsimp),
      smt (verit, best) sep_disj_multD2 sep_disj_multI2 sep_mult_assoc,
      blast,
      metis mult_1_class.mult_1_left sep_magma_1_right)
*)

lemma [φreason %ToA_splitting_target+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ * _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R1 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (R1 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R' 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌 R' 𝗐𝗂𝗍𝗁 P1 ∧ P2 @tag 𝒯𝒫 "
  for A :: ‹'a::{sep_semigroup, sep_magma_1} BI›
  unfolding Premise_def Action_Tag_def
  by (simp add: mult.assoc transformation_left_frame transformation_trans)
  


subsubsection ‹Entry Point of Transformation Reasoning›

setup ‹Config.put_global (Phi_Syntax.enable_auto_chk_and_conv) false›

(*
consts NToA' :: ‹bool ― ‹whether to reason deeper transformation for each desired φ-type
                          by invoking more time-consuming reasoning process,
                          or just apply unification to match the desired.›
              ⇒ mode›
      ― ‹Normalized ToA reasoning, the usual ToA reasoning having simplification and other
          normalization at the beginning.›

text ‹The boolean flag indicates whether to reason the transformation of φ-types in depth.
For ‹X⇩1 * ⋯ * X⇩n 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y⇩1 * ⋯ * Y⇩m' ?flag›,

▪ If the flag is turned on, for every desired φ-Type \<^term>‹Y⇩i›, the reasoner
  infers in depth whether some source φ-Type \<^term>‹X⇩j› can be transformed into \<^term>‹Y⇩i›,
  by invoking any configured reasoning rules bound on the type of \<^term>‹Y⇩i›.

▪ If the flag is turned off, such in-depth inference is not applied, so the
  reasoning succeeds only if for every desired φ-Type \<^term>‹Y⇩i› there is another
  \<^term>‹X⇩j› that unifies \<^term>‹Y⇩i›.

The the flag is turned off, obviously the performance can be improved a lot though
the reasoning is weaker.
›

abbreviation ‹NToA ≡ NToA' True›
*)

paragraph ‹Major Implementation›

subparagraph ‹Short-cuts›

lemma [φreason %ToA_refl for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?X 𝗐𝗂𝗍𝗁 ?P›
                             ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?var 𝗐𝗂𝗍𝗁 ?P›]:
  ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X›
  unfolding Action_Tag_def using transformation_refl .

lemma [φreason %ToA_red for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 ?P›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗌𝗎𝖻𝗃 True 𝗐𝗂𝗍𝗁 P ›
  unfolding Action_Tag_def by simp

lemma [φreason %ToA_normalizing for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Any
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y ›
  unfolding Action_Tag_def
  by (simp add: transformation_weaken)

subparagraph ‹ML›

(*
consts ToA_flag_deep :: bool

abbreviation ‹NToA'' X ≡ φTagA (NToA' X) ›

φreasoner_group NToA_src = (%ToA_systop+30, [%ToA_systop, %ToA_systop+60])
                           for (‹NToA'' _ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y›)
                            in ToA_systop ‹›

lemma "_NToA_init_":
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ Pop_Envir_Var ToA_flag_deep
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def Simplify_def Identity_Element⇩I_def
  by simp
*)

ML ‹
val augment_ToA_by_implication = Attrib.setup_config_bool \<^binding>‹augment_ToA_by_implication› (K false)
val under_NToA_ctxt = Config.declare_bool ("under_NToA_ctxt", ⌂) (K false)

structure ToA_Hooks = Hooks (
  type arg = {deep: bool}
  type state = context_state
)

val NToA_init_having_Q = @{lemma
  ‹ X 𝗂𝗆𝗉𝗅𝗂𝖾𝗌 Q
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 Q ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫›
  by (clarsimp simp: 𝗋EIF_def Simplify_def Identity_Element⇩I_def Satisfiable_def Premise_def
                     Action_Tag_def Transformation_def, blast)}
›


φreasoner_ML ToR_Entry_Point 2000 (‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?var_P›) = ‹
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val sequent = skolemize_transformation ctxt sequent
      val (ctxt, sequent) = normalize_source_of_ToA (ctxt, sequent)
      val sequent = @{thm' Action_Tag_D[where A=‹𝒯𝒫›]} RS sequent
      val sequent = if Config.get ctxt augment_ToA_by_implication
                    then NToA_init_having_Q RS sequent
                    else sequent
   in SOME ((ctxt,sequent), Seq.empty)
  end
)›

(*
thm φTagA_def

φreasoner_ML NToA_init 2000 (‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?Y 𝗐𝗂𝗍𝗁 ?var_P _›) = ‹
fn (_, (ctxt0,sequent)) => Seq.make (fn () =>
  let val _ (*Trueprop*) $ ( _ (*Action_Tag*) $ _ $ (Const(\<^const_name>‹NToA'›, _) $ deep))
         = Thm.major_prem_of sequent
      val sequent = @{thm' Action_Tag_I} RS sequent

      val ctxt = Context.proof_map (PLPR_Env.push \<^const_name>‹ToA_flag_deep› deep) ctxt0
              |> Config.put under_NToA_ctxt true
      val deep = case deep of \<^Const>‹True› => true | _ => false

      val rule = if deep then @{thm' φTagA_def[where mode=‹NToA' True›, symmetric]}
                         else @{thm' φTagA_def[where mode=‹NToA' False›, symmetric]}
      val insert_tag_tgt = Phi_Syntax.conv_items_of_assertion (fn ctxt => fn ctm =>
            let val term = Thm.term_of ctm
             in if is_Var (Term.head_of term)
                then Conv.all_conv ctm
                else case term
                       of Const(\<^const_name>‹φType›, _) $ _ $ _ => Conv.rewr_conv rule ctm
                        | _ => Conv.all_conv ctm
            end)

      fun insert_tag_src ctxt ctm =
        case Thm.term_of ctm
          of Const(\<^const_name>‹ExSet›, _) $ _ =>
              Conv.arg_conv (Phi_Conv.abs_conv_eta (fn (_, ctxt) => insert_tag_src ctxt) ctxt) ctm
           | Const(\<^const_name>‹AllSet›, _) $ _ =>
              Conv.arg_conv (Phi_Conv.abs_conv_eta (fn (_, ctxt) => insert_tag_src ctxt) ctxt) ctm
           | Const(\<^const_name>‹Subjection›, _) $ _ $ _ =>
              Conv.arg1_conv (insert_tag_src ctxt) ctm
           | Const(\<^const_name>‹plus›, _) $ _ $ _ =>
              Conv.combination_conv (Conv.arg_conv (insert_tag_src ctxt)) (insert_tag_src ctxt) ctm
           | Const(\<^const_name>‹Additive_Conj›, _) $ _ $ _ =>
              Conv.combination_conv (Conv.arg_conv (insert_tag_src ctxt)) (insert_tag_src ctxt) ctm
           | _ => Conv.rewr_conv rule ctm

      val sequent = skolemize_transformation ctxt sequent
      val sequent = Conv.gconv_rule (Phi_Conv.hhf_concl_conv (fn ctxt =>
            Phi_Syntax.transformation_conv (insert_tag_src ctxt) (insert_tag_tgt ctxt) Conv.all_conv
          ) ctxt) 1 sequent

      val sequent = @{thm "_NToA_init_"} RS sequent

      val ctxt = Config.restore under_NToA_ctxt ctxt0 ctxt

   in SOME ((ctxt, sequent), Seq.empty)
  end)
›

φreasoner_ML NToA_init⇩S %NToA_src (‹NToA'' _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›) = ‹
fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val sequent = Conv.gconv_rule (Phi_Conv.hhf_concl_conv (fn _ =>
            Phi_Syntax.transformation_conv (Conv.rewr_conv @{thm' φTagA_def}) Conv.all_conv Conv.all_conv
          ) ctxt) 1 sequent

      val deep = case PLPR_Env.get \<^const_name>‹ToA_flag_deep› (Context.Proof ctxt)
                   of SOME (Const(\<^const_name>‹True›, _)) => true
                    | _ => false

      val (ctxt, sequent) = normalize_source_of_ToA (ctxt, sequent)

      val sequent = if deep andalso Config.get ctxt augment_ToA_by_implication
                    then @{thm' "_NToA_init_having_Q_"} RS sequent
                    else sequent

   in SOME ((ctxt, sequent), Seq.empty)
  end
)›
*)

(*
lemma [φreason ! %NToA_tgt]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗐𝗂𝗍𝗁 Q›
  unfolding φTagA_def .

lemma [φreason ! %NToA_tgt]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (A * (B * C)) 𝗐𝗂𝗍𝗁 Q
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (A * B * C) 𝗐𝗂𝗍𝗁 Q ›
  for X :: ‹'a::sep_semigroup set›
  by (simp add: mult.assoc)
*)

(*
lemma [φreason ! %NToA_tgt]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 Q ›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
  by clarsimp metis

lemma [φreason ! %NToA_tgt]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x ⦂ T) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (SP_TGT C⇩R R Y False ⊤ P2 True)
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ U) * Y 𝗐𝗂𝗍𝗁 P1 ∧ P2›
  for X :: ‹'a::sep_magma_1 BI›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
            φTagA_def SP_TGT_def REMAINS_def Identity_Element⇩E_def
  by (cases C⇩R; clarsimp; metis mult_1_class.mult_1_right sep_magma_1_left)

lemma [φreason ! %NToA_tgt
        except ‹(_ :: ?'a::sep_magma_1 BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ ›]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒 P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (x ⦂ T) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C⇩R
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫)
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (y ⦂ U) * Y 𝗐𝗂𝗍𝗁 P1 ∧ P2›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
            φTagA_def SP_TGT_def REMAINS_def Identity_Element⇩E_def
  by (cases C⇩R; clarsimp; metis mult_1_class.mult_1_right sep_magma_1_left)


lemma [φreason ! %NToA_tgt-1]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * NToA'' d R 𝗐𝗂𝗍𝗁 Q
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (Y * R) 𝗐𝗂𝗍𝗁 Q›
  unfolding φTagA_def .

lemma [φreason ! %NToA_tgt if ‹chk_target_of_ToA_requires_normalization (fn _ $ (_ $ X) $ _ $ _ => X)›]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q
― ‹⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q)›
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (y ⦂ U) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
            φTagA_def
  by (cases C; clarsimp; meson)

lemma [φreason ! %NToA_tgt-1]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 Q›
  unfolding φTagA_def .

lemma [φreason ! %NToA_tgt if ‹chk_target_of_ToA_requires_normalization (fn _ $ X => X)›]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗌𝗎𝖻𝗃 y. r y @tag 𝒜transitive_simp_if_need False False
⟹ Object_Equiv U eq
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[𝗌𝖺𝖿𝖾] P : (∀y'. r y' ⟶ eq y' y)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗐𝗂𝗍𝗁 Q
― ‹⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ T 𝗐𝗂𝗍𝗁 Q)›
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d (y ⦂ U) 𝗐𝗂𝗍𝗁 Q›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
            φTagA_def
  by (clarsimp; metis)

lemma [φreason ! %NToA_tgt[bottom]]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 Q
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 NToA'' d Y 𝗐𝗂𝗍𝗁 Q›
  unfolding Action_Tag_def Transformation_def Premise_def Object_Equiv_def Simplify_def
            φTagA_def
  by clarsimp

hide_fact "_NToA_init_"
*)

setup ‹Config.put_global Phi_Syntax.enable_auto_chk_and_conv true›





(* if Cw then (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Crr] RR 𝗐𝗂𝗍𝗁 P2) else (P2, Crr) = (True, False)
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps unspec]
        (C, R3) : (Cr ∨ Crr ∨ ¬ Cw,
                   if Crr then if Cr then RR * (snd y ⦂ R) else RR
                   else if Cw then if Cr then (snd y ⦂ R) else ⊤
                   else if Cr then A * (snd y ⦂ R) else A) *)

(* TODO: DO NOT REMOVE
lemma enter_SEi_TH:
  ‹ Try Cp ((x,w) ⦂ T ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁
        Auto_Transform_Hint (y'1 ⦂ U' ∗[Cr] R') (x'1 ⦂ T' ∗[Cw] W') ∧ P1)
⟹ if Cw then (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Crr] RR 𝗐𝗂𝗍𝗁
                    Auto_Transform_Hint (y'2 ⦂ W') A' ∧ P2)
          else (P2, Crr) = (True, False)
⟹ if Cw then ATH = (A' * (x'3 ⦂ T')) else ATH = (x'3 ⦂ T')
⟹ 𝗌𝗂𝗆𝗉𝗅𝗂𝖿𝗒[assertion_simps unspec]
        (C, R3) : (Cr ∨ Crr ∨ ¬ Cw,
                   if Crr then if Cr then RR * (snd y ⦂ R) else RR
                   else if Cw then if Cr then (snd y ⦂ R) else ⊤
                   else if Cr then A * (snd y ⦂ R) else A)
⟹ A * (x ⦂ T) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R3 𝗐𝗂𝗍𝗁
        Auto_Transform_Hint (y'3 ⦂ U) ATH ∧ P2 ∧ P1›
  for A :: ‹'a::sep_semigroup BI›
  unfolding Auto_Transform_Hint_def HOL.simp_thms(22)
  using enter_SEi .*)

(* not used
lemma enter_SEa:
  ‹ C = True ∧⇩𝗋 (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 P) ∧⇩𝗋 (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 Q) ∨⇩c⇩u⇩t 
    (C, y) = (False, fst y') ∧⇩𝗋
    ((x, w) ⦂ T ∗[True] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁 P) ∧⇩𝗋
    (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 Q)
⟹ A * (x ⦂ T) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ∧ Q ›
  unfolding Action_Tag_def Orelse_shortcut_def Ant_Seq_def
  by (cases C; simp add: φSome_φProd φSome_transformation_strip;
      clarsimp simp add: Transformation_def; blast)

(*TODO:
lemma enter_SEa_TH:
  ‹ (C, ATH) = (True, x'2 ⦂ T') ∧⇩𝗋
    (x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗐𝗂𝗍𝗁 Auto_Transform_Hint (y'2 ⦂ U') (x'2 ⦂ T') ∧ P) ∧⇩𝗋
    (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 Q)
    ∨⇩c⇩u⇩t
    (C, ATH, y) = (False, A' * (x'2) ⦂ T', fst y') ∧⇩𝗋
    ((x, w) ⦂ T ∗[True] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y' ⦂ U ∗[False] ⊤⇩φ 𝗐𝗂𝗍𝗁
          Auto_Transform_Hint (y'1 ⦂ U' ∗[False] ⊤⇩φ) (x'1 ⦂ T' ∗[True] W') ∧ P) ∧⇩𝗋
    (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 Auto_Transform_Hint (y'2 ⦂ W') A' ∧ Q)
⟹ A * (x ⦂ T) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁
        Auto_Transform_Hint (y'2 ⦂ U') ATH ∧ P ∧ Q ›
  unfolding Action_Tag_def Orelse_shortcut_def Ant_Seq_def Auto_Transform_Hint_def
  by (cases C; simp add: φSome_φProd φSome_φNone_freeobj φSome_transformation_strip;
      clarsimp simp add: Transformation_def; blast)
*)
*)

(*
definition ‹SE_tail_Rw C⇩W A w W P2
  ⟷ (if C⇩W then A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2 else Identity_Element⇩I A P2) ›

declare [[
  φreason_default_pattern ‹SE_tail_Rw ?C⇩W ?A _ _ _› ⇒ ‹SE_tail_Rw ?C⇩W ?A _ _ _› (100)
]]

lemma [φreason %SE_internal]:
  ‹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫
⟹ SE_tail_Rw True A w W P2 ›
  unfolding SE_tail_Rw_def Action_Tag_def
  by simp

lemma [φreason %SE_internal]:
  ‹ Identity_Element⇩I A P2
⟹ SE_tail_Rw False A w W P2 ›
  unfolding SE_tail_Rw_def
  by simp

lemma [φreason %SE_internal_err]:
  ‹ ERROR TEXT(‹ToA: condition variables are not literal› Cw)
⟹ SE_tail_Rw Cw A w W P2 ›
  unfolding ERROR_def
  by simp


lemma enter_SEbi⇩1:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ if C⇩R then Identity_Element⇩I (snd y ⦂ R) Q else Q = True
⟹ SE_tail_Rw C⇩W A w W P2
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗐𝗂𝗍𝗁 P2 ∧ Q ∧ P1 @tag 𝒯𝒫 ›
  for A :: ‹'a :: sep_magma_1 set›
  unfolding Action_Tag_def φProd_expn' Identity_Element⇩I_def Premise_def
            Transformation_def Try_def Ant_Seq_def SE_tail_Rw_def
  by (cases C⇩W; cases C⇩R; clarsimp; fastforce)

lemma enter_SEbi:
  ‹ (x, w) ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫'
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[𝗌𝖺𝖿𝖾] (¬ C⇩R ∧ C⇩W)
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 P2
⟹ (x ⦂ T) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗐𝗂𝗍𝗁 P2 ∧ P1 @tag 𝒯𝒫 ›
  for A :: ‹'a :: sep_magma set›
  unfolding Action_Tag_def φProd_expn' Identity_Element⇩I_def Premise_def
            Transformation_def Try_def Identity_Element⇩E_def Ant_Seq_def
  by (cases C⇩W; cases C⇩R; clarsimp; blast)

hide_const (open) SE_tail_Rw
*)

(* TODO: DO NOT REMOVE
lemma enter_SEbi_TH:
  ‹ Try Cp ((x, w) ⦂ T ∗[C] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[Cr] R 𝗐𝗂𝗍𝗁
        Auto_Transform_Hint (y' ⦂ U') (x' ⦂ T' ∗[C] W') ∧ P1)
⟹ if Cr then Identity_Element⇩I (snd y ⦂ ● R) Q else Q = True
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 w ⦂ W 𝗐𝗂𝗍𝗁 Auto_Transform_Hint (w' ⦂ W') A' ∧ P2
⟹ A * (x ⦂ T) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 fst y ⦂ U 𝗐𝗂𝗍𝗁
        Auto_Transform_Hint (y' ⦂ U') (A' * (x'' ⦂ T')) ∧ P2 ∧ Q ∧ P1 ›
  for A :: ‹'a :: sep_magma set›
  unfolding Auto_Transform_Hint_def HOL.simp_thms(22)
  using enter_SEbi .
*)

(*
ML ‹
fun SE_entry_point rules thy sequent =
  let val (_, Y, _) = Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
      val ty = Phi_Syntax.dest_transformation_typ (Thm.major_prem_of sequent)

      fun sel_obj x T =
            let val var = Term.head_of x
             in if is_Var var andalso not (exists_subterm (fn y => x aconv y) T)
                then fst else snd
            end
      fun parse (Const(\<^const_name>‹REMAINS›, _)
                    $ (Const(\<^const_name>‹φType›, _) $ x $ T)
                    $ C
                    $ _)
            = sel_obj x T
                  (if Sign.of_sort thy (ty, \<^sort>‹sep_magma_1›) andalso
                      (case C of Const(\<^const_name>‹True›, _) => true | _ => false)
                   then #1 rules else #2 rules)
        | parse (Const(\<^const_name>‹φType›, _) $ x $ T)
            = sel_obj x T
                  (if Sign.of_sort thy (ty, \<^sort>‹sep_magma_1›)
                   then #1 rules else #2 rules)

   in parse Y RS sequent
  end

val SE_entry_point_normal = SE_entry_point (
      (@{thm' enter_SE}, @{thm' ToA_by_Equiv_Class'[OF _ _ enter_SE]}),
      (@{thm' enter_SEi}, @{thm' ToA_by_Equiv_Class'[OF _ _ enter_SEi]}))

val SE_entry_point_b = SE_entry_point (
      (@{thm' enter_SEbi⇩1}, @{thm' ToA_by_Equiv_Class[OF _ _ enter_SEbi⇩1]}),
      (@{thm' enter_SEbi}, @{thm' ToA_by_Equiv_Class[OF _ _ enter_SEbi]}))

›


φreasoner_ML 𝒜SE_Entry default %ToA_splitting_source (‹(_ ⦂ _) * (_::?'a::sep_semigroup BI) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›)
= ‹fn (_, (ctxt, sequent)) =>
  Seq.make (fn () =>
    let val thy = Proof_Context.theory_of ctxt
        (*val (ctxt, sequent) = normalize_target_of_ToA (ctxt, sequent) *)
     in if Sign.of_sort thy (Phi_Syntax.dest_transformation_typ (Thm.major_prem_of sequent), \<^sort>‹sep_magma›)
        then SOME ((ctxt, SE_entry_point_normal thy sequent), Seq.empty)
        else (warning "The reasoner can barely do nothing for those even are not sep_magma" ;
              NONE)
    end
)›

φreasoner_ML 𝒜SEb_Entry default %ToA_splitting_source (‹(_ ⦂ _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ 𝗐𝗂𝗍𝗁 _›) = ‹fn (_, (ctxt, sequent)) =>
  Seq.make (fn () =>
    let val thy = Proof_Context.theory_of ctxt
        (*val (ctxt, sequent) = normalize_target_of_ToA (ctxt, sequent)*)
     in if Sign.of_sort thy (Phi_Syntax.dest_transformation_typ (Thm.major_prem_of sequent), \<^sort>‹sep_magma›)
        then SOME ((ctxt, SE_entry_point_b thy sequent), Seq.empty)
        else (warning "The reasoner can barely do nothing for those even are not sep_magma" ;
              NONE)
    end)›
*)

lemma ToA_splitting_source_no_remainder_first
      [no_atp, φreason %ToA_splitting_source except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ :: ?'a :: sep_semigroup set) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " C = False ∧⇩𝗋 (A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫) ∨⇩c⇩u⇩t
    (C,P) = (True, P1 ∧ P2) ∧⇩𝗋 (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P1 @tag 𝒯𝒫) ∧⇩𝗋
    (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P2 @tag 𝒯𝒫))
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Orelse_shortcut_def Transformation_def REMAINS_def Premise_def Ant_Seq_def Action_Tag_def
  by clarsimp blast

(*
lemma ToA_splitting_source_has_remainder_first[no_atp]:
  " (C,P) = (True, P1 ∧ P2) ∧⇩𝗋 (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P1) ∧⇩𝗋 (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 P1 ⟶ (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R 𝗐𝗂𝗍𝗁 P2)) ∨⇩c⇩u⇩t
    C = False ∧⇩𝗋 (A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P)
⟹ A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  unfolding Orelse_shortcut_def Transformation_def REMAINS_def Premise_def Ant_Seq_def
  by clarsimp blast
*)

(* TODO:
hide_fact enter_SEb enter_SEb_TH*)



subsection ‹Supplementary Transformations›

subsubsection ‹Supplementary for Ex \& Conj \label{supp-ex-conj}›

ML ‹fun ToA_ex_intro_reasoning (ctxt,sequent) =
  let val (_, X'', _) = Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
      fun parse (Const(\<^const_name>‹ExSet›, \<^Type>‹fun \<^Type>‹fun ty _› _›) $ X) = (false, ty, X)
        | parse (Const(\<^const_name>‹REMAINS›, _) $ (Const(\<^const_name>‹ExSet›, \<^Type>‹fun \<^Type>‹fun ty _› _›) $ X) $ _ $ _)
            = (true, ty, X)
        | parse X = parse (Envir.beta_eta_contract X)
      val (has_focus, _, X'1) = parse X''
      val X = case X'1 of Abs (_, _, X) => X | X => Term.incr_boundvars 1 X $ Bound 0
      val ex_var_is_in_obj_only = Phi_Syntax.forall_item_of_assertion_blv (fn (_,lv) =>
                                    (fn (Const(\<^const_name>‹φType›, _) $ _ $ T) => not (Term.loose_bvar1 (T, lv))
                                      | A => not (Term.loose_bvar1 (A, lv)))) []
      val rule0 = if has_focus
                  then if ex_var_is_in_obj_only X
                  then @{thm' ExSet_transformation_I_R[where x=‹id c› for c,
                                      OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]}
                  else @{thm' ExSet_transformation_I_R[
                                      OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]}
                  else if ex_var_is_in_obj_only X
                  then @{thm' ExSet_transformation_I[where x=‹id c› for c,
                                      OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]}
                  else @{thm' ExSet_transformation_I[
                                      OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]}
   in SOME ((ctxt, rule0 RS sequent), Seq.empty)
  end›

φreasoner_ML ToA_ex_intro default ! %ToA_inst_qunat ( ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExSet _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                                    | ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ExSet _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› )
  = ‹fn stat => Seq.make (fn () => ToA_ex_intro_reasoning (snd stat))›

(*diverges to 3 branches, left branch, right branch, and instantiating the Ex in the domain if any. *)
φreasoner_ML NToA_conj_src ! %ToA_branches  (‹_ ∧⇩B⇩I _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›) = ‹fn (_, (ctxt,sequent)) => Seq.make (fn () =>
  let val tail = (case Phi_Syntax.dest_transformation (Thm.major_prem_of sequent)
                    of (_, Const(\<^const_name>‹ExSet›, _) $ X, _) =>
                            if Term.exists_Const (fn (\<^const_name>‹Additive_Conj›, _) => true
                                                   | _ => false) X
                            then Seq.make (fn () => ToA_ex_intro_reasoning (ctxt,sequent))
                            else Seq.empty
                     | _ => Seq.empty)
   in SOME ((ctxt, @{thm' NToA_conj_src_A
                            [OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]} RS sequent),
        Seq.make (fn () => SOME ((ctxt, @{thm' NToA_conj_src_B
                            [OF Action_Tag_D[where A=‹𝒯𝒫›], THEN Action_Tag_I[where A=‹𝒯𝒫›]]} RS sequent), tail)))
  end
  )›


subsubsection ‹Evaluations›

lemma [φreason %ToA_red]:
  ‹ (y,x) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ prod.swap (x,y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (f x, y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ apfst f (x,y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (x, f y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ apsnd f (x,y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ x ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ fst (x,y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ y ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ snd (x,y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (x, z) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (fst (x,y), z) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (y, z) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (snd (x,y), z) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (x, y) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x, fst (y, z)) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ (x, z) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x, snd (y, z)) ⦂ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

subsubsection ‹Let›

lemma [φreason %ToA_red]:
  " T x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P
⟹ Let x T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U x 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Let x U 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

lemma [φreason %ToA_red]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 U x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Let x U 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  unfolding Let_def .

subsubsection ‹Case Prod›

φreasoner_group ToA_red_caseprod =
  (%ToA_red, [%ToA_red, %ToA_red+10]) for (‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod _ _ 𝗐𝗂𝗍𝗁 _›, ‹case_prod _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›)
  ‹Transformations reducing ‹case_prod››

lemma [φreason %ToA_red_caseprod+10]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f x y 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f (x,y) 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod+10]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f x y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f (x,y) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod+10]:
  " A x y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹ case_prod A (x,y) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P"
  by simp

lemma [φreason %ToA_red_caseprod]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f (fst xy) (snd xy) 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f xy 𝗐𝗂𝗍𝗁 P"
  unfolding Transformation_def
  by (cases xy; simp)

lemma [φreason %ToA_red_caseprod]:
  " T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 f (fst xy) (snd xy) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ T 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_prod f xy 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P"
  unfolding Transformation_def
  by (cases xy; cases C; simp)

lemma [φreason %ToA_red_caseprod]:
  " A (fst xy) (snd xy) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹ case_prod A xy 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P"
  by (cases xy; simp)


subsubsection ‹Conditional Branch›

paragraph ‹Normalization›

lemma [φreason %ToA_normalizing]:
  ‹ If C (x ⦂ A) (x ⦂ B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by (cases C; simp)

text ‹\<^term>‹x ⦂ (If C T U) ∗[C⇩W] W› is not reduced because the ‹C⇩W› and ‹W› have to be specially assigned.›

(*TODO: the following rule is limited!! W⇩1, W⇩2*)

lemma [φreason %ToA_normalizing]: ― ‹‹W› shouldn't contain schematic variable. Why a source can contain
                                      variable?›
  ‹ If C ((x ⦂ A) * W) ((x ⦂ B) * W) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ (x ⦂ If C A B) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P›
  by (cases C; simp)

lemma [φreason %ToA_normalizing]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C (x ⦂ A) (x ⦂ B) 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 x ⦂ If C A B 𝗐𝗂𝗍𝗁 P›
  by (cases C; simp)

paragraph ‹Reduction for constant boolean condition›

subparagraph ‹Source›

lemma NToA_cond_source_A[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ (if C then A else B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_B[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ (if C then A else B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_A_ty[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ x ⦂ T ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ (if C then T else U) ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)

lemma NToA_cond_source_B_ty[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ x ⦂ U ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P
⟹ x ⦂ (if C then T else U) ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P›
  unfolding Action_Tag_def Premise_def 𝗋Guard_def
  by (simp add: Transformation_def distrib_left)


subparagraph ‹Target›

lemma NToA_cond_target_A[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_B[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_A'[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_B'[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_A_ty[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ T ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (if C then T else U) ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp

lemma NToA_cond_target_B_ty[φreason %ToA_red]:
  ‹ 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (if C then T else U) ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P›
  unfolding Premise_def 𝗋Guard_def
  by simp


paragraph ‹When the condition boolean is a variable›

text ‹The condition should be regarded as an output, and the reasoning process assigns which
the branch that it chooses to the output condition variable.›

subparagraph ‹Normalizing›

lemma [φreason %ToA_red for ‹If (id ?var) _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ If C T U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ If (id C) T U 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_red for ‹_ ⦂ If (id ?var) _ _ ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ x ⦂ If C T U ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ x ⦂ If (id C) T U ∗[C⇩W] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'›
  unfolding Action_Tag_def
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If (id ?var) _ _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A B 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If (id C) A B 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (If (id ?var) _ _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫' ›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (If C A B) ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (If (id C) A B) ∗[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫' ›
  by simp

subparagraph ‹Source›

text ‹the ‹id ?x› here is the protector generated by instantiating existence in target.›

declare [[φreason ! %ToA_branches NToA_cond_source_A NToA_cond_source_B
        for ‹(if ?var_condition then ?A else ?B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ?X 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫›]]

hide_fact NToA_cond_source_A NToA_cond_source_B

declare [[φreason ! %ToA_branches NToA_cond_source_A_ty NToA_cond_source_B_ty
      for ‹_ ⦂ (if ?var then _ else _) ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]]

hide_fact NToA_cond_source_A_ty NToA_cond_source_B_ty


subparagraph ‹Target›

declare [[φreason ! %ToA_branches NToA_cond_target_A NToA_cond_target_B
            for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var_condition then ?A else ?B) 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫› ]]

hide_fact NToA_cond_target_A NToA_cond_target_B

declare [[φreason ! %ToA_branches NToA_cond_target_B' NToA_cond_target_A'
            for ‹?X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var_condition then ?A else ?B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 ?P @tag 𝒯𝒫› ]]

hide_fact NToA_cond_target_A' NToA_cond_target_B'

declare [[φreason ! %ToA_branches NToA_cond_target_A_ty NToA_cond_target_B_ty
            for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (if ?var then _ else _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› ]]

hide_fact NToA_cond_target_A_ty NToA_cond_target_B_ty


paragraph ‹Case Split›

φreasoner_group ToA_splitting_If = (%ToA_splitting, [%ToA_splitting, %ToA_splitting+1])
                                   for (‹If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y›, ‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C A B›)
                                    in ToA_splitting
  ‹ToA splitting ‹If› in either source or target, into two sub-goals.›

subparagraph ‹Source›

lemma ToA_cond_branch_src:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  unfolding Action_Tag_def
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

lemma ToA_cond_branch_src_R:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb] Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

(*lemma ToA_cond_branch_src_R':
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ P = False) ∨⇩c⇩u⇩t (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ Q = False) ∨⇩c⇩u⇩t (B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)
*)

lemma [φreason %ToA_splitting_If]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ (x ⦂ T⇩a ∗[C⇩W⇩a] W⇩a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a ⦂ U ∗[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ (x ⦂ T⇩b ∗[C⇩W⇩b] W⇩b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b ⦂ U ∗[Cb] Rb 𝗐𝗂𝗍𝗁 Q  @tag 𝒯𝒫'))
⟹ x ⦂ (If C T⇩a T⇩b) ∗[If C C⇩W⇩a C⇩W⇩b] (If C W⇩a W⇩b) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C y⇩a y⇩b ⦂ U ∗[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫' ›
  unfolding Try_def
  by (cases C; simp add: Premise_def Orelse_shortcut_def)
  
ML ‹
fun reasoner_ToA_conditioned_subgoals_If ctxt'N (vars,Y,RHS) =
  let val (C, Ya, Yb) = Phi_Help.dest_triop_c \<^const_name>‹If› RHS
      val C_term = Thm.term_of C

      val Ya_s = map (fn ((N,i),ty) => Thm.var ((N,i+2), Thm.ctyp_of ctxt'N ty)) vars
      val Yb_s = map (fn ((N,i),ty) => Thm.var ((N,i+3), Thm.ctyp_of ctxt'N ty)) vars 
      val Y_s  = map2 (fn a => fn b =>
                   let val ty = Thm.typ_of_cterm a
                    in Thm.apply (Thm.apply (
                          Thm.apply (Thm.cterm_of ctxt'N \<^Const>‹If ty›) C
                        ) a
                        ) b
                   end) Ya_s Yb_s
      val Ya' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Ya_s)) Y
      val Yb' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Yb_s)) Y
      fun mk_inst ctm Y =
        case Thm.term_of ctm
          of _ $ Free _ => mk_inst (Thm.dest_fun ctm) (Thm.lambda (Thm.dest_arg ctm) Y)
           | Var v => (v, Y)
           | _ => error "BUG: reasoner_ToA_conditioned_subgoals"
 
   in (Vars.make (mk_inst Ya Ya' :: mk_inst Yb Yb' :: (vars ~~ Y_s)), C_term)
  end
›


lemma If_distrib_fx:
  ‹(If C fa fb) (If C va vb) ≡ (If C (fa va) (fb vb))›
  unfolding atomize_eq
  by (cases C; simp)

lemma If_distrib_arg:
  ‹(If C fa fb) a ≡ (If C (fa a) (fb a))›
  unfolding atomize_eq
  by (cases C; simp)
 
φreasoner_ML ‹ML (If C A B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)› %ToA_splitting_If
             ( ‹If _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
             | except ‹If ?var _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›)
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_cond_branch_src}, @{thm' ToA_cond_branch_src_R},
          (true, @{thms' if_cancel[folded atomize_eq]}, @{thms' if_True if_False}),
          reasoner_ToA_conditioned_subgoals_If, \<^context>) o snd›


subparagraph ‹Target›

lemma [φreason %ToA_splitting_If except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

lemma [φreason %ToA_splitting_If except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb] Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)

(*
lemma [φreason %ToA_splitting_If+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if _ then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ 𝗐𝗂𝗍𝗁 _›
                    except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if ?var then _ else _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,False)) ∨⇩c⇩u⇩t (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,False)) ∨⇩c⇩u⇩t (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then A else B) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Premise_def Orelse_shortcut_def)*)

lemma [φreason %ToA_splitting_If except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (if ?var then _ else _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a ⦂ T ∗[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b ⦂ U ∗[Cb] Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫'))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then y⇩a else y⇩b) ⦂ (if C then T else U) ∗[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫' ›
  unfolding Try_def Premise_def Orelse_shortcut_def
  by (cases C; simp)


subsubsection ‹Conditioned Remains›

paragraph ‹When the conditional boolean is fixed›

φreasoner_group ToA_constant_remains = (%ToA_splitting_source, [%ToA_splitting_source-4,%ToA_splitting_source+2])
                                        for (‹X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R 𝗐𝗂𝗍𝗁 P›)
                                         in ToA ‹›

lemma [φreason default %ToA_constant_remains-2 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 C⇩R
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  unfolding Premise_def
  by simp

lemma [φreason default %ToA_constant_remains-1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] (?var::?'c::sep_magma_1 BI) 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C⇩R] R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ if C⇩R then R = R' else R = 1
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  for R :: ‹'c :: sep_magma_1 BI›
  by (cases C⇩R; simp)

lemma [φreason default %ToA_constant_remains-3 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] R 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp

lemma [φreason %ToA_normalizing for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] ⊤ 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp


paragraph ‹Reduction›

subparagraph ‹Source›

lemma ToA_CR_src_A [φreason %ToA_red]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ Y * R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp

lemma ToA_CR_src_B [φreason %ToA_red+10 for ‹_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                            ‹_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp

lemma ToA_CR_src_A' [φreason %ToA_red]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ (Y * R) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp

lemma ToA_CR_src_B' [φreason %ToA_red+10 for ‹(_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                             ‹(_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ Y * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp


subparagraph ‹Target›

lemma ToA_CR_target_A [φreason %ToA_red]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] C
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X * R 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 "
  unfolding 𝗋Guard_def Premise_def
  by simp

lemma ToA_CR_target_B [φreason %ToA_red+10 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[False] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
                                               ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ C
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (X 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫"
  unfolding 𝗋Guard_def Premise_def Action_Tag_def
  by simp


paragraph ‹Case Split›

subparagraph ‹Source›

lemma ToA_cond_remain_src:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)

lemma ToA_cond_remain_src_R:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A * B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb] Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)

(*
lemma ToA_cond_remain_src_R':
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,False)) ∨⇩c⇩u⇩t (B * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,False)) ∨⇩c⇩u⇩t (A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)
*)

lemma ToA_cond_remain_src_W:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A * B * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (A * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)

lemma ToA_cond_remain_src_WR:
  ‹ Y = If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (A * B * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca] Ra 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (A * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb] Rb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫 ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)

(*
lemma ToA_cond_remain_src_WR':
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,False)) ∨⇩c⇩u⇩t (W * (B * A) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,False)) ∨⇩c⇩u⇩t (W * A 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ W * (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; simp add: Orelse_shortcut_def Premise_def)
*)


φreasoner_ML ‹ML (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P)› %ToA_splitting (‹_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›)
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_cond_remain_src}, @{thm' ToA_cond_remain_src_R}, (*@{thm' ToA_cond_remain_src_R'},*)
          (true, @{thms' if_cancel[folded atomize_eq]}, @{thms' if_True if_False}),
          reasoner_ToA_conditioned_subgoals_If, \<^context>) o snd›

φreasoner_ML ‹ML ((A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] B) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P)› %ToA_splitting (‹(_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›)
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_cond_remain_src_W}, @{thm' ToA_cond_remain_src_WR}, (*@{thm' ToA_cond_remain_src_WR'},*)
          (true, @{thms' if_cancel[folded atomize_eq]}, @{thms' if_True if_False}),
          reasoner_ToA_conditioned_subgoals_If, \<^context>) o snd›


subparagraph ‹Target›

(*TODO: reasoner_ToA_conditioned_subgoals*)
lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y * R 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[CCa] RRa 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟶ (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[CCb] RRb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C CCa CCb] If C RRa RRb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫›
  unfolding Premise_def Ant_Seq_def Orelse_shortcut_def
  by (cases C; simp)

(*
lemma [φreason %ToA_splitting+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] _ 𝗐𝗂𝗍𝗁 _›
                                except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _› ]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 R * Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] RRa 𝗐𝗂𝗍𝗁 P)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] RRb 𝗐𝗂𝗍𝗁 Q)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C RRa RRb 𝗐𝗂𝗍𝗁 If C P Q›
  by (cases C; simp)*)

paragraph ‹When the condition boolean is a variable›

subparagraph ‹Normalizing›

lemma [φreason %ToA_red for ‹_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id ?var] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[V] R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id V] R 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp

lemma [φreason %ToA_red for ‹(_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id ?var] _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[V] R) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id V] R) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp

lemma [φreason %ToA_red for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id ?var] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[V] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (A 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[id V] R) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R' 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫 ›
  by simp

subparagraph ‹Source›

declare [[φreason ! %ToA_branches ToA_CR_src_A ToA_CR_src_B
        for ‹_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]]

hide_fact ToA_CR_src_A ToA_CR_src_B

declare [[φreason ! %ToA_branches ToA_CR_src_A' ToA_CR_src_B'
        for ‹(_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]]

hide_fact ToA_CR_src_A' ToA_CR_src_B'

subparagraph ‹Target›

declare [[φreason ! %ToA_branches ToA_CR_target_A ToA_CR_target_B
            for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (_ 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[?var] _) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› ]]

hide_fact ToA_CR_target_A ToA_CR_target_B



subsubsection ‹Type-embedding of Conditioned Remains›

paragraph ‹Reduction›

subparagraph ‹Source›

lemma ToA_CRφ_src_A [φreason %ToA_red]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] CC
⟹ x ⦂ (T1 ∗ T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ x ⦂ (T1 ∗[CC] T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P  @tag 𝒯𝒫'"
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def
  by simp

lemma ToA_CRφ_src_B [φreason %ToA_red+10 for ‹_ ⦂ (_ ∗[False] _) ∗ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
                                             ‹_ ⦂ (_ ∗[?var] _) ∗ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ CC
⟹ (fst (fst x), snd x) ⦂ T1 ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ x ⦂ (T1 ∗[CC] T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 X 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'"
  unfolding Transformation_def split_paired_All 𝗋Guard_def Premise_def Action_Tag_def
  by simp

subparagraph ‹Target›

lemma ToA_CRφ_target_A [φreason %ToA_red]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] CC
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (U ∗ R) ∗[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (U ∗[CC] R) ∗[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'"
  unfolding 𝗋Guard_def Premise_def
  by simp

lemma ToA_CRφ_target_B [φreason %ToA_red+10 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[False] _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
                                                 ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[?var] _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  " 𝗀𝗎𝖺𝗋𝖽 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇[NO_INST] ¬ CC
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U ∗[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'
⟹ Y 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ((fst y, unspec), snd y) ⦂ (U ∗[CC] R) ∗[C] R2 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'"
  unfolding 𝗋Guard_def Premise_def
  by (cases C; simp add: φProd_expn' φProd_expn'')

paragraph ‹Case Split›

subparagraph ‹Source›

lemma [φreason %ToA_splitting]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩a,P,Cwa,W⇩a,C⇩R⇩a,R⇩a,y⇩a) = (unspec, False, True, ⊥⇩φ, True, ⊥⇩φ, unspec) ∨⇩c⇩u⇩t
                      (x ⦂ (T1 ∗ T2) ∗[Cwa] W⇩a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a ⦂ U ∗[C⇩R⇩a] R⇩a 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩b,Q,Cwb,W⇩b,C⇩R⇩b,R⇩b,y⇩b) = (unspec, False, True, ⊥⇩φ, True, ⊥⇩φ, unspec) ∨⇩c⇩u⇩t
                      (apfst fst x ⦂ T1 ∗[Cwb] W⇩b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b ⦂ U ∗[C⇩R⇩b] R⇩b 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫'))
⟹ x ⦂ (T1 ∗[C] T2) ∗[If C Cwa Cwb] If C W⇩a W⇩b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 If C y⇩a y⇩b ⦂ U ∗[If C C⇩R⇩a C⇩R⇩b] If C R⇩a R⇩b 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫' ›
  unfolding Orelse_shortcut_def Premise_def Ant_Seq_def
  by (cases C; simp ; cases Cwb; simp add: φProd_expn'' φProd_expn')


(*
lemma ToA_cond_septy_src:
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ P = False) ∨⇩c⇩u⇩t
                      (x ⦂ (T1 ∗ T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ Q = False) ∨⇩c⇩u⇩t
                      ((fst (fst x), snd x) ⦂ T1 ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗐𝗂𝗍𝗁 Q))
⟹ x ⦂ (T1 ∗[C] T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; cases Cw;
      simp add: Orelse_shortcut_def Premise_def φProd_expn'' φProd_expn')

lemma ToA_cond_septy_src_R:
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ca,Ra,P) = (False,0,False)) ∨⇩c⇩u⇩t
                      (x ⦂ (T1 ∗ T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Cb,Rb,Q) = (False,0,False)) ∨⇩c⇩u⇩t
                      ((fst (fst x), snd x) ⦂ T1 ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ x ⦂ (T1 ∗[C] T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[If C Ca Cb] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; cases Cw;
      simp add: Orelse_shortcut_def Premise_def φProd_expn'' φProd_expn')

(*
lemma ToA_cond_septy_src_R':
  ‹ Y ≡ If C Ya Yb
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,False)) ∨⇩c⇩u⇩t
                      (x ⦂ (T1 ∗ T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra 𝗐𝗂𝗍𝗁 P))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,False)) ∨⇩c⇩u⇩t
                      ((fst (fst x), snd x) ⦂ T1 ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb 𝗐𝗂𝗍𝗁 Q))
⟹ x ⦂ (T1 ∗[C] T2) ∗[Cw] W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] If C Ra Rb 𝗐𝗂𝗍𝗁 If C P Q ›
  by (cases C; cases Cw;
      simp add: Orelse_shortcut_def Premise_def φProd_expn'' φProd_expn')
*)

φreasoner_ML ‹ML (x ⦂ (T1 ∗[C] T2) ∗ W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P)› %ToA_splitting (‹_ ⦂ (_ ∗[_] _) ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _›)
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_cond_septy_src}, @{thm' ToA_cond_septy_src_R}, (*@{thm' ToA_cond_septy_src_R'},*)
          (\<^const_name>‹If›, 3, @{thms' if_cancel[folded atomize_eq]}, @{thms' If_distrib_fx if_distrib}),
          reasoner_ToA_conditioned_subgoals_If, \<^context>) o snd›
*)

subparagraph ‹Target›

lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[?var] _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩a,CCa,RRa,P) = (unspec,True,⊥⇩φ,False) ∨⇩c⇩u⇩t
                     (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a ⦂ (U ∗ R) ∗[CCa] RRa 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫'))
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩b,CCb,RRb,Q) = (unspec,True,⊥⇩φ,False) ∨⇩c⇩u⇩t
                     (X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b ⦂ U ∗[CCb] RRb 𝗐𝗂𝗍𝗁 Q @tag 𝒯𝒫'))
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then y⇩a else apfst (λx. (x, unspec)) y⇩b) ⦂ (U ∗[C] R) ∗[If C CCa CCb] If C RRa RRb 𝗐𝗂𝗍𝗁 If C P Q @tag 𝒯𝒫'›
  unfolding Ant_Seq_def Orelse_shortcut_def Premise_def
  by (cases C; simp; cases CCb; simp add: φProd_expn' φProd_expn'')

(*
lemma [φreason %ToA_splitting+1 for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[_] _) ∗[True] _ 𝗐𝗂𝗍𝗁 _›
                                except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[?var] _) ∗[_] _ 𝗐𝗂𝗍𝗁 _› ]:
  ‹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇   C ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 ya ⦂ (U ∗ R) ∗[True] RRa 𝗐𝗂𝗍𝗁 P)
⟹ (𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 ¬ C ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 yb ⦂ U ∗[True] RRb 𝗐𝗂𝗍𝗁 Q)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 (if C then ya else ((fst yb, unspec), snd yb)) ⦂ (U ∗[C] R) ∗[True] If C RRa RRb 𝗐𝗂𝗍𝗁 If C P Q›
  by (cases C; simp add: φProd_expn' φProd_expn'')*)

paragraph ‹When the condition boolean is a variable›

subparagraph ‹Source›

declare [[φreason ! %ToA_branches ToA_CRφ_src_A ToA_CRφ_src_B
        for ‹_ ⦂ (_ ∗[?var] _) ∗[_] _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]]

hide_fact ToA_CRφ_src_A ToA_CRφ_src_B

subparagraph ‹Target›

declare [[φreason ! %ToA_branches ToA_CRφ_target_A ToA_CRφ_target_B
            for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (_ ∗[?var] _) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'› ]]

hide_fact ToA_CRφ_target_A ToA_CRφ_target_B



subsubsection ‹Case Sum›

paragraph ‹Reduction›

subparagraph ‹Target›

lemma ToA_case_sum_target_L[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inl x) 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma ToA_case_sum_target_L'[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inl x) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma ToA_case_sum_target_L_ty[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U⇩a c ∗[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ case_sum U⇩a U⇩b (Inl c) ∗[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma ToA_case_sum_target_R[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B x 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inr x) 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma ToA_case_sum_target_R'[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (Inr x) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma ToA_case_sum_target_R_ty[φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ U⇩b c ∗[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ case_sum U⇩a U⇩b (Inr c) ∗[C] R 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]: ― ‹This form can occur when reducing ‹y ⦂ (T +⇩φ U) ∗[C] R››
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (fst (x, y)) 𝗐𝗂𝗍𝗁 P ›
  by simp


subparagraph ‹Source›

lemma [φreason %ToA_red]:
  ‹ A x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ case_sum A B (Inl x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ case_sum A B (Inr x) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ A x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ case_sum A B (Inl x) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]:
  ‹ B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ case_sum A B (Inr x) * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp

lemma [φreason %ToA_red]: ― ‹This form can occur when reducing ‹x ⦂ (T +⇩φ U) ∗[C] W››
  ‹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P
⟹ case_sum A B (fst (x, y)) 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P ›
  by simp


paragraph ‹Case Split›

subparagraph ‹Target›

lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫 ›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp)

lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca a] Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb b] Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[case_sum Ca Cb x] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp add: Simplify_def)

lemma [φreason %ToA_splitting+1 except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (case_sum _ _ ?var) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ (xx, w⇩a a) ⦂ T ∗[C⇩W⇩a a] W⇩a a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a a ⦂ U⇩a a ∗[C⇩a a] R⇩a a 𝗐𝗂𝗍𝗁 P⇩a a @tag 𝒯𝒫')
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ (xx, w⇩b b) ⦂ T ∗[C⇩W⇩b b] W⇩b b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b b ⦂ U⇩b b ∗[C⇩b b] R⇩b b 𝗐𝗂𝗍𝗁 P⇩b b @tag 𝒯𝒫')
⟹ (xx, case_sum w⇩a w⇩b x) ⦂ T ∗[case_sum C⇩W⇩a C⇩W⇩b x] (case_sum W⇩a W⇩b x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum y⇩a y⇩b x ⦂ (case_sum U⇩a U⇩b x) ∗[case_sum C⇩a C⇩b x] (case_sum R⇩a R⇩b x) 𝗐𝗂𝗍𝗁 case_sum P⇩a P⇩b x @tag 𝒯𝒫' ›
  unfolding Premise_def Try_def
  by (cases x; simp)


(*TODO: Type level case split on SE gonna be a disaster!
        Every type variables between the two branches have to be independent! but here, the R⇩a and R⇩b
        are forced having identical abstract type! The abstract type of R⇩a and R⇩b instead should be
        a sum type!
  TODO: the case split now is broken!
*)
(*
lemma (*TODO-0918*)
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ (xx, w⇩a a) ⦂ T ∗[C⇩W⇩a a] W⇩a a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a a ⦂ U⇩a a ∗[C⇩a a] R⇩a a 𝗐𝗂𝗍𝗁 P⇩a a)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ (xx, w⇩b b) ⦂ T ∗[C⇩W⇩b b] W⇩b b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b b ⦂ U⇩b b ∗[C⇩b b] R⇩b b 𝗐𝗂𝗍𝗁 P⇩b b)
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 S⇩a ∨ S⇩b
⟹ (xx, case_sum (Inl o w⇩a) (Inr o w⇩b) x) ⦂ T ∗[case_sum C⇩W⇩a C⇩W⇩b x] (case_sum (Inl⇩φ W⇩a) (Inr⇩φ W⇩b) x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum y⇩a y⇩b x ⦂ (case_sum U⇩a U⇩b x) ∗[case_sum C⇩a C⇩b x] (case_sum R⇩a R⇩b x) 𝗐𝗂𝗍𝗁 case_sum P⇩a P⇩b x ›
  unfolding Premise_def Try_def
  sorry
*)

lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (case_sum _ _ ?var) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ (fst xx, w⇩a a) ⦂ T ∗[C⇩W⇩a a] W⇩a a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a a ⦂ U⇩a a ∗[C⇩a a] R⇩a a 𝗐𝗂𝗍𝗁 P⇩a a @tag 𝒯𝒫')
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ (fst xx, w⇩b b) ⦂ T ∗[C⇩W⇩b b] W⇩b b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b b ⦂ U⇩b b ∗[C⇩b b] R⇩b b 𝗐𝗂𝗍𝗁 P⇩b b @tag 𝒯𝒫')
⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 S⇩a ∨ S⇩b
⟹ 𝗉𝗋𝖾𝗆𝗂𝗌𝖾 snd xx = case_sum w⇩a w⇩b x
⟹ xx ⦂ T ∗[case_sum C⇩W⇩a C⇩W⇩b x] (case_sum W⇩a W⇩b x)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum y⇩a y⇩b x ⦂ (case_sum U⇩a U⇩b x) ∗[case_sum C⇩a C⇩b x] (case_sum R⇩a R⇩b x) 𝗐𝗂𝗍𝗁 case_sum P⇩a P⇩b x @tag 𝒯𝒫' ›
  unfolding Premise_def Try_def
  by (cases x; cases xx; simp)

(*
lemma [φreason %ToA_splitting except ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›
                                     ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ (id ?var) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 A a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a)
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 B b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b)
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B x 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def)*)


subparagraph ‹Source›

lemma ToA_case_sum_src:
  ‹ Y = case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 P = (λ_. False) ∨⇩c⇩u⇩t (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 Q = (λ_. False) ∨⇩c⇩u⇩t (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

lemma ToA_case_sum_src_R:
  ‹ Y = case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (Ca,Ra,P) = ((λ_. True),0,(λ_. False)) ∨⇩c⇩u⇩t (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca a] Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (Cb,Rb,Q) = ((λ_. True),0,(λ_. False)) ∨⇩c⇩u⇩t (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb b] Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[case_sum Ca Cb x] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

(*lemma ToA_case_sum_src_R':
  ‹ Y ≡ case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨⇩c⇩u⇩t (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨⇩c⇩u⇩t (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)*)
(*
lemma [φreason %ToA_splitting for ‹case_sum (λ_. _ ⦂ _ ∗[_] _) (λ_. _ ⦂ _ ∗[_] _) _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩a,C⇩W⇩a,W⇩a,Ca,Ra,P) = (unspec, (λ_. True), (λ_. ⊥⇩φ), (λ_. True), (λ_. ⊥⇩φ), (λ_. False)) ∨⇩c⇩u⇩t
                                (x⇩a a ⦂ T⇩a a ∗[C⇩W⇩a a] W⇩a a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a a ⦂ U ∗[Ca a] Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (y⇩b,C⇩W⇩b,W⇩b,Cb,Rb,Q) = (unspec, (λ_.True), (λ_. ⊥⇩φ), (λ_.True), (λ_. ⊥⇩φ), (λ_. False)) ∨⇩c⇩u⇩t
                                (x⇩b b ⦂ T⇩b b ∗[C⇩W⇩b b] W⇩b b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b b ⦂ U ∗[Cb b] Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ (case x of Inl a ⇒ x⇩a a ⦂ T⇩a a ∗[C⇩W⇩a a] W⇩a a | Inr b ⇒ x⇩b b ⦂ T⇩b b ∗[C⇩W⇩b b] W⇩b b)
    𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum y⇩a y⇩b x ⦂ U ∗[case_sum Ca Cb x] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  unfolding Try_def Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def
  by (cases x; simp)
*)
(*
lemma [φreason %ToA_splitting+1 for ‹case_sum _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ _ ∗[_] _ 𝗐𝗂𝗍𝗁 _›]:
  ‹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨⇩c⇩u⇩t
                                (A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩a a ⦂ U ∗[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨⇩c⇩u⇩t
                                (B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y⇩b b ⦂ U ∗[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum y⇩a y⇩b x ⦂ U ∗[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)*)

lemma ToA_case_sum_src_W:
  ‹ Y = case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 P = (λ_. False) ∨⇩c⇩u⇩t (A a * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 Q = (λ_. False) ∨⇩c⇩u⇩t (B b * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

lemma ToA_case_sum_src_WR:
  ‹ Y = case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (Ca,Ra,P) = ((λ_. True),0,(λ_. False)) ∨⇩c⇩u⇩t
                                (A a * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Ca a] Ra a 𝗐𝗂𝗍𝗁 P a @tag 𝒯𝒫))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False ∧⇩𝗋 (Cb,Rb,Q) = ((λ_. True),0,(λ_. False)) ∨⇩c⇩u⇩t
                                (B b * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[Cb b] Rb b 𝗐𝗂𝗍𝗁 Q b @tag 𝒯𝒫))
⟹ case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[case_sum Ca Cb x] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x @tag 𝒯𝒫 ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def Ant_Seq_def)

(*lemma ToA_case_sum_src_WR':
  ‹ Y ≡ case_sum Ya Yb x
⟹ (⋀a. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inl a ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Ra,P) = (0,(λ_. False))) ∨⇩c⇩u⇩t (W * A a 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Ya a 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Ra a 𝗐𝗂𝗍𝗁 P a))
⟹ (⋀b. 𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 x = Inr b ⟹ ((𝖼𝗈𝗇𝖽𝗂𝗍𝗂𝗈𝗇 False) ∧ (Rb,Q) = (0,(λ_. False))) ∨⇩c⇩u⇩t (W * B b 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Yb b 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] Rb b 𝗐𝗂𝗍𝗁 Q b))
⟹ W * case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[True] case_sum Ra Rb x 𝗐𝗂𝗍𝗁 case_sum P Q x ›
  by (cases x; simp add: Simplify_def Premise_def Orelse_shortcut_def)
*)
lemma case_sum_degenerate:
  ‹(case_sum (λ_. a) (λ_. a) x) ≡ a›
  unfolding atomize_eq
  by (cases x; simp) 

lemma sum_case_distrib_fx:
  ‹(case_sum fa fb x) (case_sum va vb x) ≡ (case_sum (λx. fa x (va x)) (λx. fb x (vb x)) x)›
  unfolding atomize_eq
  by (cases x; simp)

lemma sum_case_distrib_arg:
  ‹(case_sum fa fb x) a ≡ (case_sum (λx. fa x a) (λx. fb x a) x)›
  unfolding atomize_eq
  by (cases x; simp)

ML ‹
(*instantiates variables vs to ‹case_sum va vb x› for each*)
fun reasoner_ToA_conditioned_subgoals_sum ctxt'N (vars,Y,RHS) =
  let val (Ya, Yb, x) = Phi_Help.dest_triop_c \<^const_name>‹case_sum› RHS
      val \<^Type>‹sum ta tb› = Thm.typ_of_cterm x
      val ([Na,Nb], ctxt'N) = Variable.variant_fixes ["xa","xb"] ctxt'N
      val xa = Thm.cterm_of ctxt'N (Free (Na, ta))
      val xb = Thm.cterm_of ctxt'N (Free (Nb, tb))
      val x_term = Thm.term_of x

      val Ya_s = map (fn ((N,i),ty) => Thm.apply (Thm.var ((N,i+2), Thm.ctyp_of ctxt'N (ta --> ty))) xa) vars
      val Yb_s = map (fn ((N,i),ty) => Thm.apply (Thm.var ((N,i+3), Thm.ctyp_of ctxt'N (tb --> ty))) xb) vars 
      val Y_s  = map2 (fn a => fn b =>
                   let val ty = Thm.typ_of_cterm a
                    in Thm.apply (Thm.apply (Thm.apply (
                            Thm.cterm_of ctxt'N \<^Const>‹case_sum ta ty tb›) (Thm.dest_fun a)
                        ) (Thm.dest_fun b)) x
                   end) Ya_s Yb_s
      val Ya' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Ya_s)) Y
             |> Thm.lambda xa
      val Yb' = Thm.instantiate_cterm (TVars.empty, Vars.make (vars ~~ Yb_s)) Y
             |> Thm.lambda xb
      fun mk_inst ctm Y =
        case Thm.term_of ctm
          of _ $ Free _ => mk_inst (Thm.dest_fun ctm) (Thm.lambda (Thm.dest_arg ctm) Y)
           | Var v => (v, Y)
           | _ => error "BUG: reasoner_ToA_conditioned_subgoals"

   in (Vars.make (mk_inst Ya Ya' :: mk_inst Yb Yb' :: (vars ~~ Y_s)), x_term)
  end
›

φreasoner_ML ‹ML (case_sum A B x 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)› %ToA_splitting
        ( ‹case_sum _ _ _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
        | except ‹case_sum _ _ ?var 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›)
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_case_sum_src}, @{thm' ToA_case_sum_src_R}, (*@{thm' ToA_case_sum_src_R'},*)
          (true, @{thms' case_sum_degenerate}, @{thms' sum.case}),
          reasoner_ToA_conditioned_subgoals_sum, \<^context>) o snd›

φreasoner_ML ‹ML (case_sum A B x * W 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 Y 𝗐𝗂𝗍𝗁 P @tag 𝒯𝒫)› %ToA_splitting
        ( ‹case_sum _ _ _ * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›
        | except ‹case_sum _ _ ?var * _ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫› )
  = ‹Phi_Reasoners.reasoner_ToA_conditioned_subgoals
         (@{thm' ToA_case_sum_src_W}, @{thm' ToA_case_sum_src_WR}, (*@{thm' ToA_case_sum_src_WR'},*)
          (true, @{thms' case_sum_degenerate}, @{thms' sum.case}),
          reasoner_ToA_conditioned_subgoals_sum, \<^context>) o snd›


paragraph ‹When the sum type is a variable›

subparagraph ‹Normalizing›

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B var 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (id var) 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum A B (id var) 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[C] R 𝗐𝗂𝗍𝗁 P›
  by simp

lemma [φreason %ToA_red]:
  ‹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (case_sum A B var) ∗[C] R 𝗐𝗂𝗍𝗁 P
⟹ X 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 y ⦂ (case_sum A B (id var)) ∗[C] R 𝗐𝗂𝗍𝗁 P›
  by simp

subparagraph ‹Major Reasoning›

declare [[
    φreason ! %ToA_branches ToA_case_sum_target_L ToA_case_sum_target_R
        for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›,
    φreason ! %ToA_branches ToA_case_sum_target_L' ToA_case_sum_target_R'
        for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 case_sum _ _ ?var 𝗋𝖾𝗆𝖺𝗂𝗇𝗌[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫›,
    φreason ! %ToA_branches ToA_case_sum_target_L_ty ToA_case_sum_target_R_ty
        for ‹_ 𝗍𝗋𝖺𝗇𝗌𝖿𝗈𝗋𝗆𝗌 _ ⦂ (case_sum _ _ ?var) ∗[_] _ 𝗐𝗂𝗍𝗁 _ @tag 𝒯𝒫'›
]]

(*TODO: the source part!*)


section ‹Helpful Stuffs›

subsection ‹Methods›

method_setup represent_BI_pred_in_φType = ‹Args.term >> (fn X => fn ctxt => Method.METHOD (K (fn th =>
  let val T = Thm.cterm_of ctxt X
      val ty_a = Thm.ctyp_of_cterm T |> Thm.dest_ctyp0
      val ty_c = Thm.ctyp_of_cterm T |> Thm.dest_ctyp1 |> Thm.dest_ctyp0
   in case Thm.prop_of th
   of Const(\<^const_name>‹Pure.imp›, _) $ _ $ _ =>
      Seq.single (Conv.gconv_rule (Conv.bottom_conv (fn _ => fn ctm =>
       case Thm.term_of ctm
         of X' $ _ => if X' aconv X
                      then Conv.rewr_conv \<^instantiate>‹T and x = ‹Thm.dest_arg ctm›
                                                        and 'c = ty_c and 'a = ty_a
                                                        in lemma ‹T x ≡ x ⦂ T› for T :: ‹('c,'a) φ›
                                                              by (simp add: φType_def)› ctm
                      else Conv.all_conv ctm
          | _ => Conv.all_conv ctm
      ) ctxt) 1 th)
    | _ => Seq.empty
  end
)))›

end